61static void symatterr(
int,
int,
const char *);
80#ifdef FLANG_SEMANT_UNUSED
81static int has_length_type_parameter(
int);
95static void fixup_ident_bounds(
int);
157#define BYVALDEFAULT(ffunc) \
158 (!(PASSBYREFG(ffunc)) && \
159 (PASSBYVALG(ffunc) | STDCALLG(ffunc) | CFUNCG(ffunc)))
173#define ERR310(s1, s2) error(310, 3, gbl.lineno, s1, s2)
182#define ET_ALLOCATABLE 1
183#define ET_DIMENSION 2
186#define ET_INTRINSIC 5
188#define ET_PARAMETER 7
192#define ET_AUTOMATIC 11
196#define ET_VOLATILE 15
202#define ET_CONSTANT 21
203#define ET_PROTECTED 22
204#define ET_ASYNCHRONOUS 23
208#define ET_CONTIGUOUS 27
210#define ET_IMPL_MANAGED 29
215#define ET_B(e) (1 << e)
217#define SYMI_SPTR(i) aux.symi_base[i].sptr
218#define SYMI_NEXT(i) aux.symi_base[i].next
363 {
"implicit-managed", 0},
372#define DA_DLLEXPORT 3
373#define DA_DLLIMPORT 4
375#define DA_REFERENCE 6
377#define DA_NOMIXEDSLA 8
382#define DA_B(e) (1 << e)
412 {
"nomixed_str_len_arg", 0},
601#if defined(TARGET_WIN)
629 }
else if (
gbl.internal) {
644 if (
XBIT(49, 0x1040000))
669 int byval_default = 0;
672 if (STYPEG(
gbl.currsub) == ST_MODULE)
675 for (thesub =
gbl.currsub; thesub >
NOSYM; thesub = SYMLKG(thesub)) {
676 dpdsc = DPDSCG(thesub);
677 for (iarg = PARAMCTG(thesub); iarg > 0; dpdsc++, iarg--) {
685 if (((
DTY(DTYPEG(psptr))) == TY_ARRAY) ||
686 ((
DTY(DTYPEG(psptr))) == TY_STRUCT)) {
687 if (PASSBYVALG(thesub) || PASSBYVALG(psptr))
689 "- VALUE derived types and arrays not yet supported");
692 if (PASSBYVALG(psptr) && OPTARGG(psptr)) {
698 if ((byval_default || PASSBYVALG(psptr)) && (!PASSBYREFG(psptr)) &&
699 (
DTY(DTYPEG(psptr)) != TY_ARRAY) &&
701 (strncmp(
SYMNAME(psptr),
"_V_", 3) != 0)) {
711 if (newsptr >
NOSYM) {
718 DCLDP(newsptr,
TRUE);
720 SCP(psptr, SC_LOCAL);
722 MIDNUMP(newsptr, psptr);
725 if (psptr ==
itemp->t.sptr) {
726 itemp->t.sptr = newsptr;
735 switch (STYPEG(psptr)) {
738 STYPEP(psptr, ST_VAR);
751 else if (thesub !=
gbl.currsub && SCG(psptr) == SC_LOCAL) {
784 SPTR sptr, sptr1, sptr2, block_sptr, sptr_temp, lab;
785 int dtype, dtypeset,
ss, numss;
786 int stype, stype1,
i;
799 int name_prefix_char;
821 static int proc_interf_sptr;
831 case SYSTEM_GOAL_SYMBOL1:
852 error(155, 3,
gbl.lineno,
"ENUMERATOR statement expected",
CNULL);
881 error(155, 3,
gbl.lineno,
"USE",
"is not in a correct position.");
913 if (stt == TK_NAMED_CONSTRUCT)
932 p =
"ACC REGION LOOP";
936 p =
"ACC KERNELS DO";
940 p =
"ACC KERNELS LOOP";
944 p =
"ACC PARALLEL DO";
948 p =
"ACC PARALLEL LOOP";
952 p =
"ACC SERIAL LOOP";
956 p =
"CUDA KERNEL DO";
968 p =
"OMP TARGET SIMD";
979 p =
"OMP DISTRIBUTE";
984 p =
"OMP TARGET PARALLEL DO";
989 p =
"OMP DISTRIBUTE PARALLEL DO";
995 }
else if (
scn.
stmtyp == TK_MP_ENDTARGET) {
1015 p =
"PARALLEL DO SIMD";
1032 error(155, 3,
gbl.lineno,
"DO loop expected after",
p);
1045 if (stt == TK_NAMED_CONSTRUCT)
1053 error(155, 4,
gbl.lineno,
"DO loop expected after",
"COLLAPSE");
1069 if (
scn.
stmtyp != TK_MP_ENDDISTRIBUTE) {
1082 if (
scn.
stmtyp != TK_MP_ENDTARGTEAMSDIST) {
1099 if (
scn.
stmtyp != TK_MP_ENDTEAMSDISTPARDO &&
1100 scn.
stmtyp != TK_MP_ENDTEAMSDISTPARDOSIMD) {
1107 if (
scn.
stmtyp != TK_MP_ENDTARGTEAMSDISTPARDO &&
1108 scn.
stmtyp != TK_MP_ENDTARGTEAMSDISTPARDOSIMD) {
1167 "Statement after ATOMIC UPDATE is not an assignment",
CNULL);
1175 "Statement after ATOMIC UPDATE is not an assignment",
CNULL);
1204 "Only a CLASS IS, TYPE IS, CLASS DEFAULT, or END SELECT"
1205 " statement may follow a SELECT TYPE statement",
1235 goto statement_shared;
1242 goto statement_shared;
1262 }
else if (
scn.
stmtyp == TK_PARAMETER) {
1287 goto statement_shared;
1294 goto statement_shared;
1301 goto executable_shared;
1308 goto executable_shared;
1338 "- must be followed by a keyword or an identifier");
1342 goto executable_shared;
1366 error(155, 3,
gbl.lineno,
"Generic INTERFACE with the same name as a "
1367 "derived type may only contain functions -",
1371 if (GNCNTG(gnr) == 0)
1377 "Generic INTERFACE may not mix functions and subroutines",
1387 "Assignment INTERFACE requires subroutines -",
1389 else if (PARAMCTG(
gbl.currsub) != 2)
1391 "Assignment INTERFACE requires subroutines 2 arguments -",
1395 error(155, 3,
gbl.lineno,
"Operator INTERFACE requires functions -",
1397 else if (PARAMCTG(
gbl.currsub) != 1 && PARAMCTG(
gbl.currsub) != 2)
1400 "Operator INTERFACE requires functions with 1 or 2 arguments -",
1435 goto statement_shared;
1480 goto executable_shared;
1483 error(155, 3,
gbl.lineno,
"Internal subprograms may not be nested",
1485 goto executable_shared;
1522 int lab =
declref(labsym, ST_LABEL,
'd');
1532 goto statement_shared;
1535 if (ANCESTORG(
gbl.currmod) && !HAS_SMP_DECG(ANCESTORG(
gbl.currmod)))
1547 goto statement_shared;
1550 goto executable_shared;
1587 ecs =
mk_stmt(A_MP_ENDATOMIC, 0);
1598 ast_atomic =
mk_stmt(A_ENDATOMIC, 0);
1659 if (
gbl.internal == 1) {
1662 if (STYPEG(
gbl.currsub) == ST_ENTRY)
1663 STYPEP(
gbl.currsub, ST_PROC);
1670 }
else if (
gbl.internal > 1) {
1722 if (STYPEG(
gbl.currsub) == ST_ENTRY && FVALG(
gbl.currsub) &&
1723 prevphase <= PHASE_USE && sem.pgphase >
PHASE_USE) {
1724 int retdtype = DTYPEG(FVALG(
gbl.currsub));
1725 int dtsptr =
DTY(retdtype + 3);
1726 if (
DTY(retdtype) == TY_DERIVED && dtsptr >
NOSYM && !DCLDG(dtsptr)) {
1740 error(155, 1,
gbl.lineno,
"Statement is redundant in an INTERFACE block",
1773 ERR310(
"Illegal statement in the specification part of a MODULE",
CNULL);
1832 gbl.funcline =
gbl.lineno;
1861 if (SCG(
sptr) != SC_NONE)
1863 SCP(
sptr, SC_DUMMY);
1908 ERR310(
"BLOCKDATA may not appear in a MODULE",
CNULL);
1918 ERR310(
"BLOCKDATA may not appear in a MODULE",
CNULL);
1951 strcpy(
gbl.prog_file_name,
gbl.curr_file);
1973 if (sptr1 >
NOSYM) {
1989 if (STYPEG(
sptr) == ST_ALIAS) {
2005 STYPEG(
sptr) != ST_MEMBER) {
2024 if (STYPEG(
sptr) == ST_ENTRY || STYPEG(
sptr) == ST_PROC) {
2026 GSCOPEP(FVALG(
sptr), 1);
2027 }
else if (STYPEG(
sptr) == ST_UNKNOWN || STYPEG(
sptr) == ST_IDENT ||
2084 SCP(
sptr, SC_DUMMY);
2099 case ENTRY_STATEMENT1:
2102 goto entry_statement;
2106 case ENTRY_STATEMENT2:
2109 goto entry_statement;
2113 case ENTRY_STATEMENT3:
2118 error(535, 2,
gbl.lineno,
"ENTRY statement",
"FORTRAN 2008");
2156 stype = STYPEG(
sptr);
2157 if (stype == ST_ENTRY) {
2160 SCP(
sptr, SC_DUMMY);
2161 }
else if (SCG(
sptr) == SC_NONE) {
2162 if (stype != ST_UNKNOWN && stype != ST_IDENT && stype != ST_ARRAY &&
2163 stype != ST_STRUCT && stype != ST_PROC && stype != ST_VAR) {
2166 SCP(
sptr, SC_DUMMY);
2167 }
else if (SCG(
sptr) == SC_LOCAL && !SAVEG(
sptr))
2174 SCP(
sptr, SC_DUMMY);
2175 else if (SCG(
sptr) != SC_DUMMY)
2184 PARAMCTP(sptr2,
count);
2186 A_SPTRP(
ast, sptr2);
2236 ERR310(
"PROGRAM may not appear in a MODULE",
CNULL);
2282 strcpy(
gbl.prog_file_name,
gbl.curr_file);
2293 if (STYPEG(
sptr) == ST_ENTRY
2297 || (STYPEG(
sptr) == ST_PROC && CLASSG(
sptr) && VTOFFG(
sptr))) {
2306 !IS_INTERFACEG(
sptr)) {
2346 if (SCG(
sptr) != SC_DUMMY) {
2348 SCP(
sptr, SC_EXTERN);
2363 ERR310(
"MODULE prefix allowed only within a module or submodule",
CNULL);
2381 HAS_TBP_BOUND_TO_SMPP(SCOPEG(
sptr),
TRUE);
2407 if (STYPEG(
SYMI_SPTR(symi)) == ST_OPERATOR ||
2408 STYPEG(
SYMI_SPTR(symi)) == ST_USERGENERIC)
2446 }
else if (
gbl.internal) {
2450 SCP(
sptr, SC_STATIC);
2575 goto add_name_to_list;
2629 if (
gbl.internal > 1) {
2631 "- The ENTRY statement is not allowed in an internal procedure");
2662 SYMLKP(
sptr, SYMLKG(
gbl.currsub));
2667 CFUNCP(
sptr, CFUNCG(
gbl.currsub));
2674 PUREP(
sptr, PUREG(
gbl.currsub));
2691 goto add_sym_to_list;
2697 goto add_sym_to_list;
2721 goto add_sym_to_list;
2749 error(310, 3,
gbl.lineno,
"Missing ENDINTERFACE statement",
CNULL);
2758 else if (
gbl.internal > 1) {
2766 fprintf(stderr,
"OPROC %s:",
gbl.src_file);
2767 fprintf(stderr,
"%s\n",
SYMNAME(
gbl.currsub));
2799 submod_proc_endfunc:
2815 if (DTYPEG(
gbl.currsub) == DT_ASSCHAR) {
2818 "FUNCTION may not be declared character*(*) when in an INTERFACE -",
2844 error(310, 3,
gbl.lineno,
"Missing ENDINTERFACE statement",
CNULL);
2940 goto submod_proc_endfunc;
3010 "BLOCK construct in the scope of a parallel directive",
CNULL);
3015 ENCLFUNCP(block_sptr,
3030 ENCLFUNCP(lab, block_sptr);
3032 STARTLINEP(block_sptr,
gbl.lineno);
3033 STARTLABP(block_sptr, lab);
3038 ENTSTDP(block_sptr,
std);
3072 ENCLFUNCP(lab, block_sptr);
3075 ENDLABP(block_sptr, lab);
3093 error(155, 3,
gbl.lineno,
"CLASS components must be pointer or"
3127 if (POINTERG(
itemp->t.sptr)) {
3135 DCLDP(
sptr, was_declared);
3145 if (SCG(
sptr) == SC_DUMMY) {
3146 IS_PROC_DUMMYP(
sptr, 1);
3157 stype = STYPEG(
sptr);
3169 stype = STYPEG(
sptr);
3171 STYPEP(sptr2, ST_ALIAS);
3172 SYMLKP(sptr2,
sptr);
3178 if (stype == ST_GENERIC) {
3194 STYPEP(sptr2, ST_ALIAS);
3195 SYMLKP(sptr2,
sptr);
3360 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY)
3395 name_prefix_char =
'u';
3420 assert(pstsk->
type ==
's',
"ENDUNION:union not in struct",
sptr, 3);
3460 name_prefix_char =
'm';
3467 scn.
stmtyp == TK_UNION ?
"UNION: bad stype" :
"MAP: bad stype",
sptr,
3535 if (strcmp(np,
"integer") == 0 || strcmp(np,
"logical") == 0 ||
3536 strcmp(np,
"real") == 0 || strcmp(np,
"doubleprecision") == 0 ||
3537 strcmp(np,
"complex") == 0 || strcmp(np,
"character") == 0) {
3538 error(155, 3,
gbl.lineno,
"A derived type type-name must not be the same "
3539 "as the name of the intrinsic type",
3543 }
else if (RESULTG(
sptr)) {
3544 error(155, 3,
gbl.lineno,
"A derived type type-name conflicts with"
3545 " function result -",
3550 if (STYPEG(
sptr) == ST_TYPEDEF &&
DTY(DTYPEG(
sptr) + 2) == 0) {
3557 if (STYPEG(
sptr) == ST_USERGENERIC) {
3560 STYPEP(
sptr, ST_TYPEDEF);
3561 GTYPEP(origSym,
sptr);
3574 int dtype2 = DTYPEG(sym);
3577 error(155, 3,
gbl.lineno,
"Cannot EXTEND BIND(C) derived type",
3579 }
else if (
DTY(dtype2) == TY_DERIVED && SEQG(
DTY(dtype2 + 3))) {
3580 error(155, 3,
gbl.lineno,
"Cannot EXTEND SEQUENCE derived type",
3583 error(155, 3,
gbl.lineno,
"EXTENDS may not be used with BIND(C) "
3611 accessp->
oper =
' ';
3652 error(155, 3,
gbl.lineno,
"Name on END TYPE statement does not"
3653 " match name on corresponding TYPE statement",
3662 if (ALLOCFLDG(
sptr)) {
3681 if (
gbl.internal <= 1)
3686 if (!UNLPOLYG(tag)) {
3698 SDSCP(
sptr, SDSCG(oldsptr));
3699 DCLDP(
sptr, DCLDG(oldsptr));
3757 if (SCG(
sptr) != SC_DUMMY)
3758 error(134, 3,
gbl.lineno,
"- intent specified for nondummy argument",
3766 itemp1->
ast =
gbl.lineno;
3769 error(280, 2,
gbl.lineno,
"BIND: allowed only in module", 0);
3785 if (STYPEG(
sptr) != ST_OPERATOR && STYPEG(
sptr) != ST_USERGENERIC)
3787 if (STYPEG(
sptr) == ST_ARRAY && ADJARRG(
sptr))
3789 "- must not be an automatic array");
3792 accessp->
sptr = sptr1;
3795 accessp->
oper =
' ';
3796 if (
itemp->ast == 1)
3797 accessp->
oper =
'o';
3802 "- too many variables bound to name");
3805 error(280, 2,
gbl.lineno,
"BIND: allowed only in module", 0);
3858 "PUBLIC/PRIVATE may only be used in derived types",
"");
3862 ERR310(
"PUBLIC may not appear in a derived type definition",
CNULL);
3870 "Incorrect sequence of PRIVATE and type bound "
3876 "Redundant PRIVATE statement in type bound "
3877 "procedure section of",
3884 error(155, 3,
gbl.lineno,
"PRIVATE statement must appear before "
3885 "components of derived type",
3891 "Redundant PRIVATE statement in type bound "
3892 "procedure section of",
3900 "Redundant PRIVATE statement in derived type",
SYMNAME(
sptr));
3910 error(155, 2,
gbl.lineno,
"Redundant PUBLIC/PRIVATE statement",
3913 error(155, 3,
gbl.lineno,
"Conflicting PUBLIC/PRIVATE statement",
3937 if (STYPEG(
sptr) != ST_CMBLK && !DCLDG(
sptr) && !SAVEG(
sptr) &&
3940 }
else if (STYPEG(
sptr) != ST_CMBLK && ALLOCATTRG(
sptr)) {
3974 case DECLARATION41: {
3983 "- too many variables bound to name");
3985 error(84, 2,
gbl.lineno,
"BIND: allowed only in module", 0);
4008 error(4, 3,
gbl.lineno,
"Illegal BIND -", np);
4056 error(155, 3,
gbl.lineno,
"Type bound procedure part not allowed "
4057 "for SEQUENCE type",
4061 error(155, 3,
gbl.lineno,
"Type bound procedure part not allowed "
4075 "PROTECTED may only appear in the specification part of a MODULE",
4080 PROTECTEDP(
sptr, 1);
4093 "ASYNCHRONOUS statement in a BLOCK construct",
CNULL);
4150 "SEQUENCE statement must appear before components of derived type",
4155 "Redundant SEQUENCE statement in derived type",
SYMNAME(
sptr));
4158 if (PARENTG(
sptr)) {
4160 "SEQUENCE may not appear in a derived type with "
4181 PASSBYVALP(
sptr, 1);
4182 PASSBYREFP(
sptr, 0);
4196 case ACCEL_DP_STMTS1:
4201 case ACCEL_DP_STMTS2:
4208 case ACCEL_SHAPE_DECLSTMT1:
4215 case ACCEL_SHAPE_DIR1:
4219 case ACCEL_SHAPE_DIR2:
4224 case ACCEL_SHAPE_DIR3:
4228 case ACCEL_SHAPE_DIR4:
4235 case ACCEL_SHAPE_ATTRS1:
4240 case ACCEL_SHAPE_ATTRS2:
4247 case ACCEL_SHAPE_ATTR1:
4252 case ACCEL_SHAPE_ATTR2:
4257 case ACCEL_SHAPE_ATTR3:
4264 case ACCEL_DPDEFAULT_ATTR1:
4272 case ACCEL_DPINIT_NEEDED_ATTR1:
4279 case ACCEL_DPINITVAR_LIST1:
4283 case ACCEL_DPINITVAR_LIST2:
4290 case ACCEL_DPTYPE_ATTR1:
4297 case ACCEL_POLICY_DECLSTMT1:
4304 case ACCEL_POLICY_NAME1:
4308 case ACCEL_POLICY_NAME2:
4315 case ACCEL_POLICY_DIR1:
4322 case ACCEL_POLICY_ATTR_LIST1:
4327 case ACCEL_POLICY_ATTR_LIST2:
4334 case ACCEL_POLICY_ATTR1:
4339 case ACCEL_POLICY_ATTR2:
4344 case ACCEL_POLICY_ATTR3:
4349 case ACCEL_POLICY_ATTR4:
4354 case ACCEL_POLICY_ATTR5:
4359 case ACCEL_POLICY_ATTR6:
4364 case ACCEL_POLICY_ATTR7:
4369 case ACCEL_POLICY_ATTR8:
4374 case ACCEL_POLICY_ATTR9:
4381 case ACCEL_DPVARLIST1:
4386 case ACCEL_DPVARLIST2:
4412 case ACCEL_DPVAR_BNDS1:
4417 case ACCEL_DPVAR_BNDS2:
4424 case ACCEL_DPVAR_BND1:
4429 case ACCEL_DPVAR_BND2:
4453 case ACCEL_DP_BNDEXP1:
4458 case ACCEL_DP_BNDEXP2:
4465 case ACCEL_DP_ADDEXP1:
4472 case ACCEL_DP_MULEXP1:
4479 case ACCEL_ADD_OPR1:
4484 case ACCEL_ADD_OPR2:
4491 case ACCEL_MUL_OPR1:
4496 case ACCEL_MUL_OPR2:
4503 case ACCEL_DP_BNDEXP11:
4510 case ACCEL_DP_SBND1:
4515 case ACCEL_DP_SBND2:
4522 case ROUTINE_ID_LIST1:
4533 case ROUTINE_ID_LIST2:
4563 case TYPE_PARAM_SPEC_LIST1:
4569 case TYPE_PARAM_SPEC_LIST2:
4584 case OPT_DERIVED_TYPE_SPEC1:
4589 case OPT_DERIVED_TYPE_SPEC2:
4596 case TYPE_PARAM_DECL_LIST1:
4601 case TYPE_PARAM_DECL_LIST2:
4608 case TYPE_PARAM_VALUE5:
4616 case TYPE_PARAM_VALUE3:
4624 case TYPE_PARAM_VALUE1:
4629 error(155, 3,
gbl.lineno,
"A non keyword = type parameter specifier "
4630 "cannot follow a keyword = type parameter "
4641 if (A_TYPEG(
ast) == A_CNST) {
4652 case TYPE_PARAM_VALUE6:
4655 goto param_kwd_comm;
4659 case TYPE_PARAM_VALUE4:
4662 goto param_kwd_comm;
4667 case TYPE_PARAM_VALUE2:
4679 if (A_TYPEG(
ast) == A_CNST) {
4751 goto data_type_shared;
4775 "semant1: Invalid dtype for CLASS(*)", 0, 3);
4793 if (STYPEG(
sptr) != ST_TYPEDEF) {
4794 if (STYPEG(
sptr) == ST_USERGENERIC && GTYPEG(
sptr)) {
4800 }
else if (STYPEG(
sptr) == ST_UNKNOWN &&
4817 error(155, 3,
gbl.lineno,
"Derived type has not been declared -",
4884 case INTRINSIC_TYPE1:
4899 goto intrinsic_type_shared;
4903 case INTRINSIC_TYPE2:
4919 intrinsic_type_shared:
4957 error(437, 2,
gbl.lineno,
"DOUBLE PRECISION",
"REAL");
4977 error(437, 2,
gbl.lineno,
"DOUBLE COMPLEX",
"COMPLEX");
5089 switch (A_TYPEG(
ast)) {
5233 "- LEN = cannot be specified with non-character type",
CNULL);
5248 error(81, 3,
gbl.lineno,
"- LEN and KIND with non-character type",
CNULL);
5270 error(81, 3,
gbl.lineno,
"- LEN and KIND with non-character type",
CNULL);
5283 error(81, 3,
gbl.lineno,
"- LEN and KIND with non-character type",
CNULL);
5323 case LEN_KIND_SPEC1:
5336 if (A_TYPEG(
ast) != A_CNST) {
5364 case OPTIONAL_COMMA1:
5369 case OPTIONAL_COMMA2:
5417 switch (STYPEG(
sptr)) {
5431 switch (STYPEG(
sptr)) {
5441 else if (
DTY(DTYPEG(
sptr)) == TY_PTR &&
5475 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY) {
5484 if (STYPEG(
sptr) == ST_ENTRY && FVALG(
sptr)) {
5486 interr(
"semant1: data type set for ST_ENTRY with FVAL",
sptr, 3);
5492 if (STYPEG(
sptr) != ST_ENTRY && STYPEG(
sptr) != ST_MEMBER &&
5500 !ADJARRG(
sptr) && !ALLOCG(
sptr) && SCG(
sptr) != SC_DUMMY) {
5507 }
else if (
DTY(dt_dtype + 5) && SCOPEG(
sptr) &&
5578 if (STYPEG(
sptr) == ST_ENTRY && FVALG(
sptr))
5621 if (STYPEG(
sptr) != ST_UNKNOWN)
5637 STYPEP(
sptr, ST_MEMBER);
5641 if (stype == ST_IDENT)
5650 "SEQUENCE must be set for nested derived type",
5655 "Derived type component must have the POINTER attribute -",
5658 error(155, 3,
gbl.lineno,
"Derived type has not been declared -",
5672 if (
DTY(
d) == TY_DERIVED &&
DTY(
d + 3) && DISTMEMG(
DTY(
d + 3))) {
5677 int bndast, badArray;
5679 for (badArray =
i = 0;
i < numdim;
i++) {
5693 for (badArray =
i = 0;
i < numdim;
i++) {
5705 goto illegal_array_member;
5715 }
else if (A_TYPEG(bndast) != A_ID &&
5716 A_TYPEG(bndast) != A_CNST) {
5726 goto illegal_array_member;
5729 }
else if (!ALLOCG(
sptr)) {
5730 illegal_array_member:
5732 "- deferred shape array must have the POINTER "
5733 "attribute in a derived type",
5739 if (
XBIT(58, 0x10000) && !F90POINTERG(
sptr)) {
5742 if (POINTERG(
sptr) || ALLOCG(
sptr) ||
5749 SCP(
sptr, SC_BASED);
5755 stype1 = STYPEG(
sptr);
5769 if (SCG(
sptr) == SC_DUMMY || POINTERG(
sptr) || ALLOCG(
sptr)) {
5771 if (PASSBYVALG(
sptr)) {
5772 error(155, 3,
gbl.lineno,
"Polymorphic variable cannot have VALUE "
5780 "Polymorphic variable cannot be declared "
5781 "with a BIND(C) derived type - ",
5786 "Polymorphic variable cannot be declared "
5787 "with a SEQUENCE derived type - ",
5793 error(155, 3,
gbl.lineno,
"Polymorphic variable must be a pointer, "
5794 "allocatable, or dummy object - ",
5800 SCG(
sptr) != SC_DUMMY && !FVALG(
sptr) &&
5810 if (stype == ST_ARRAY) {
5818 stype1 = ST_UNKNOWN;
5827 if (
DTY(DTYPEG(
sptr)) != TY_ARRAY)
5830 goto dcl_shared_end;
5843 goto dcl_shared_end;
5851 goto dcl_shared_end;
5858 goto dcl_shared_end;
5861 }
else if (stype == ST_STRUCT) {
5869 stype1 = ST_UNKNOWN;
5870 }
else if (stype1 == ST_ARRAY && DCLDG(
sptr) == 0) {
5872 }
else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT) {
5884 stype1 = ST_UNKNOWN;
5893 stype1 = ST_UNKNOWN;
5905 if (stype1 == ST_UNKNOWN ||
5906 (stype == ST_ARRAY &&
5907 (stype1 == ST_IDENT || stype1 == ST_VAR || stype1 == ST_STRUCT))) {
5908 STYPEP(
sptr, stype);
5913 if (
DTY(
d) == TY_DERIVED &&
DTY(
d + 3) && DISTMEMG(
DTY(
d + 3))) {
5917 if (stype == ST_ARRAY) {
5918 if (POINTERG(
sptr)) {
5921 if (SCG(
sptr) != SC_DUMMY)
5923 if (!F90POINTERG(
sptr)) {
5928 if (SCG(
sptr) != SC_NONE && SCG(
sptr) != SC_DUMMY &&
5929 SCG(
sptr) != SC_BASED)
5943 if (SCG(
sptr) == SC_CMBLK)
5945 if (SCG(
sptr) == SC_DUMMY) {
5948 if (!
XBIT(54, 2) && !(
XBIT(58, 0x400000) && TARGETG(
sptr)))
5966 if (stype1 == ST_ENTRY) {
5970 interr(
"semant1: trying to set data type of ST_ENTRY",
sptr, 3);
5978 if (stype == ST_ARRAY && RESULTG(
sptr)) {
5980 if (POINTERG(
sptr)) {
5991 if (!
XBIT(54, 2) && !(
XBIT(58, 0x400000) && TARGETG(
sptr)))
5997 }
else if (stype == ST_STRUCT && stype1 == ST_IDENT)
5998 STYPEP(
sptr, ST_STRUCT);
5999 else if (stype == ST_ARRAY) {
6000 if (stype1 == ST_ENTRY) {
6004 interr(
"semant1: trying to set data type of ST_ENTRY",
sptr, 3);
6012 if (RESULTG(
sptr)) {
6014 if (POINTERG(
sptr)) {
6025 if (!
XBIT(54, 2) && !(
XBIT(58, 0x400000) && TARGETG(
sptr)))
6034 if (STYPEG(
sptr) != ST_ENTRY && STYPEG(
sptr) != ST_MEMBER &&
6055 case DIMENSION_LIST1:
6109 error(170, 2,
gbl.lineno,
"array upper bound",
"is not integer");
6128 if (A_ALIASG(
ast)) {
6135 if (A_TYPEG(
ast) == A_CONV) {
6136 if (A_LOPG(
ast) && A_TYPEG(A_LOPG(
ast)) == A_INTR)
6175 error(170, 2,
gbl.lineno,
"array lower bound",
"is not integer");
6188 if (A_ALIASG(
ast)) {
6196 if (constarraysize && arraysize < 0) {
6198 if (arraysize < 0) {
6251 case EXPLICIT_SHAPE1:
6257 case EXPLICIT_SHAPE2:
6265 case IMPLICIT_TYPE1:
6270 case IMPLICIT_TYPE2:
6290 case IMPLICIT_LIST1:
6294 case IMPLICIT_LIST2:
6332 if (FVALG(
sptr) && !DCLDG(FVALG(
sptr))) {
6355 if (begin ==
'$' || begin ==
'_' ||
end ==
'$' ||
end ==
'_') {
6418 if (STYPEG(
sptr) == ST_UNKNOWN) {
6419 STYPEP(
sptr, ST_CMBLK);
6435 if (CMEMFG(
sptr) == 0) {
6450 sptr2 =
itemp->t.sptr;
6451 stype = STYPEG(sptr2);
6461 }
else if (stype != ST_UNKNOWN && stype != ST_IDENT && stype != ST_VAR &&
6462 stype != ST_ARRAY && stype != ST_STRUCT &&
6463 (!POINTERG(sptr2))) {
6466 STYPEP(sptr2, ST_VAR);
6468 SCP(sptr2, SC_LOCAL);
6470 if (SCG(sptr2) == SC_CMBLK || SCG(sptr2) == SC_DUMMY)
6472 else if (stype == ST_ARRAY && (ASUMSZG(sptr2) || ADJARRG(sptr2)))
6474 else if (SAVEG(sptr2)) {
6478 SCP(sptr2, SC_CMBLK);
6479 CMBLKP(sptr2,
sptr);
6481 CMEMFP(
sptr, sptr2);
6484 SYMLKP(sptr2,
NOSYM);
6501 if (STYPEG(
sptr) == ST_UNKNOWN) {
6502 STYPEP(
sptr, ST_CMBLK);
6541 stype = STYPEG(
sptr);
6546 if (stype == ST_ARRAY && (ASUMSZG(
sptr) || ADJARRG(
sptr))) {
6549 "An assumed-size array cannot have the SAVE attribute -",
6551 else if (SCG(
sptr) == SC_DUMMY)
6553 "An adjustable array cannot have the SAVE attribute -",
6557 "An automatic array cannot have the SAVE attribute -",
6559 }
else if ((SCG(
sptr) == SC_NONE || SCG(
sptr) == SC_LOCAL ||
6560 SCG(
sptr) == SC_BASED) &&
6561 (stype == ST_VAR || stype == ST_ARRAY || stype == ST_STRUCT ||
6562 stype == ST_IDENT)) {
6591 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY ||
DTY(DTYPEG(
sptr)) == TY_DERIVED) {
6592 sptr1 = CONVAL1G(
sptr);
6642 if (SCG(
sptr) != SC_NONE) {
6659 CONVAL1P(
sptr, conval);
6669 A_ALIASP(
ast, alias);
6704 if (DCLDG(
sptr) || SCG(
sptr) != SC_NONE) {
6712 CONVAL1P(
sptr, conval);
6715 A_ALIASP(
ast, alias);
6780 EQV(evp).lineno =
gbl.lineno;
6781 EQV(evp).is_first = 1;
6784 EQV(evp).lineno = 0;
6785 EQV(evp).is_first = 0;
6817 error(144, 3,
gbl.lineno,
"Ugly equivalence ",
"1");
6865 "Subscript triplet not allowed in EQUIVALENCE -",
SYMNAME(
sptr));
6882 error(155, 3,
gbl.lineno,
"Member cannot be equivalenced -",
6890 case NAMELIST_GROUPS1:
6895 case NAMELIST_GROUPS2:
6902 case NAMELIST_GROUP1:
6921 case NAMELIST_LIST1:
6927 case NAMELIST_LIST2:
6963 case STRUCT_BEGIN11:
6972 case STRUCT_BEGIN12:
6986 case STRUCT_BEGIN21:
6992 case STRUCT_BEGIN22:
6999 case FIELD_NAMELIST1:
7006 case FIELD_NAMELIST2:
7029 if (STYPEG(
sptr) != ST_UNKNOWN)
7034 STYPEP(
sptr, stype);
7081 case RECORD_NAMELIST1:
7087 case RECORD_NAMELIST2:
7098 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY)
7108 }
else if (SCG(
sptr) != SC_DUMMY) {
7116 goto common_typespecs;
7163 "VOLATILE statement in a BLOCK construct",
CNULL);
7198 case DINIT_VAR_LIST1:
7206 case DINIT_VAR_LIST2:
7289 case DINIT_CONST_LIST1:
7298 case DINIT_CONST_LIST2:
7308 goto common_data_item;
7397 case DATA_CONSTANT1:
7403 case DATA_CONSTANT2:
7405 goto addop_data_constant;
7409 case DATA_CONSTANT3:
7414 case DATA_CONSTANT4:
7415 addop_data_constant:
7428 case DATA_CONSTANT5:
7442 error(155, 3,
gbl.lineno,
"Structure constructor specified"
7443 " for empty derived type",
7476 goto check_data_substring;
7499 goto check_data_substring;
7508 case DATA_CONSTANT6:
7530 case DATA_CONSTANT7:
7532 check_data_substring:
7562 if (STYPEG(
sptr) == ST_TYPEDEF &&
DTY(
dtype) == TY_DERIVED) {
7571 case IDENT_CONSTANT1:
7574 if (STYPEG(
sptr) == ST_PARAM) {
7579 if (!
XBIT(49, 0x10))
7582 goto ident_constant_error;
7587 if (
gbl.ftn_true == -1)
7600 }
else if (*np ==
'f') {
7611 goto ident_constant_error;
7615 ident_constant_error:
7642 error(171, 2,
gbl.lineno,
"- Cray POINTER statement",
CNULL);
7643 if (
XBIT(124, 0x10)) {
7645 if (DCLDG(
sptr) && DTYPEG(
sptr) != DT_INT8)
7647 DTYPEP(
sptr, DT_INT8);
7656 if (VOLG(sptr1) || SCG(sptr1) != SC_NONE) {
7660 SCP(sptr1, SC_BASED);
7661 MIDNUMP(sptr1,
sptr);
7664 if (STYPEG(sptr1) == ST_ARRAY) {
7665 if (ADJARRG(sptr1) ||
RUNTIMEG(sptr1)) {
7671 if (SCG(
sptr) == SC_BASED) {
7672 if (
sptr == sptr1) {
7673 error(155, 3,
gbl.lineno,
"Recursive POINTER declaration of",
7676 SCP(sptr1, SC_NONE);
7694 case ALLOC_ID_LIST1:
7699 case ALLOC_ID_LIST2:
7710 if (STYPEG(
sptr) == ST_UNKNOWN)
7711 STYPEP(
sptr, ST_IDENT);
7712 stype1 = STYPEG(
sptr);
7720 stype1 = ST_UNKNOWN;
7721 }
else if (stype1 == ST_ENTRY) {
7722 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY) {
7726 }
else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT && stype1 != ST_VAR &&
7727 stype1 != ST_ARRAY) {
7734 if ((
scn.
stmtyp != TK_POINTER) || (stype1 != ST_PROC)) {
7742 if (STYPEG(
sptr) == ST_PROC) {
7746 declared = DCLDG(
sptr);
7753 DCLDP(
sptr, declared);
7756 CONTIGATTRP(
sptr, 1);
7757 if (
DTYG(DTYPEG(
sptr)) == TY_DERIVED &&
XBIT(58, 0x40000)) {
7760 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY) {
7763 if (SCG(
sptr) != SC_DUMMY) {
7776 if (!F90POINTERG(
sptr)) {
7781 }
else if ((stype1 != ST_ARRAY && stype1 != ST_IDENT
7788 (!ALLOCG(
sptr) && stype1 != ST_IDENT) || SCG(
sptr) != SC_NONE)
7790 "- must be a deferred shape array");
7792 ALLOCATTRP(
sptr, 1);
7794 if (RESULTG(
sptr)) {
7806 if (STYPEG(
sptr) == ST_UNKNOWN)
7807 STYPEP(
sptr, ST_IDENT);
7808 stype1 = STYPEG(
sptr);
7816 stype1 = ST_UNKNOWN;
7817 }
else if (stype1 == ST_ENTRY) {
7818 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY) {
7822 }
else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT && stype1 != ST_VAR) {
7827 STYPEP(
sptr, ST_ARRAY);
7835 if (
DTY(
d) == TY_DERIVED &&
DTY(
d + 3) && DISTMEMG(
DTY(
d + 3))) {
7842 if (SCG(
sptr) != SC_DUMMY)
7845 if (
DTYG(DTYPEG(
sptr)) == TY_DERIVED &&
XBIT(58, 0x40000)) {
7848 if (SDSCG(
sptr) == 0 && !F90POINTERG(
sptr)) {
7854 "- must be a deferred shape array");
7857 ALLOCATTRP(
sptr, 1);
7858 if (
DTYG(DTYPEG(
sptr)) == TY_DERIVED &&
XBIT(58, 0x40000)) {
7862 if (RESULTG(
sptr)) {
7872 case OPT_ATTR_LIST1:
7876 case OPT_ATTR_LIST2:
7896 "for derived type component");
7899 error(134, 3,
gbl.lineno,
"- duplicate",
et[et_type].name);
7901 error(134, 3,
gbl.lineno,
"- conflict with",
et[et_type].name);
8037 (
gbl.currmod && !
gbl.currsub)) {
8042 "not allowed in host subprograms");
8056 (
gbl.currmod && !
gbl.currsub)) {
8061 "not allowed in host subprograms");
8073 "PROTECTED may only appear in the specification part of a MODULE",
8123#if defined(TARGET_OSX)
8145 error(4, 3,
gbl.lineno,
"Illegal BIND -", np);
8157 error(4, 3,
gbl.lineno,
"Illegal BIND syntax. Expecting: NAME Got:", np);
8165 error(4, 3,
gbl.lineno,
"Illegal BIND -", np);
8179 goto add_sym_to_bind_list;
8198 add_sym_to_bind_list:
8216 case OPT_TYPE_SPEC1:
8223 case OPT_TYPE_SPEC2:
8232 case TYPE_ATTR_LIST1:
8254 case TYPE_ATTR_LIST2:
8281 while (STYPEG(
sptr) == ST_ALIAS)
8283 if (STYPEG(
sptr) == ST_USERGENERIC && GTYPEG(
sptr)) {
8291 if (
DTY(DTYPEG(
sptr)) != TY_DERIVED) {
8292 error(155, 4,
gbl.lineno,
"Invalid type extension",
NULL);
8296 int tag =
DTY(DTYPEG(
sptr) + 3);
8297 int tag_scope = SCOPEG(tag);
8300 if (PRIVATEG(tag)) {
8301 if (STYPEG(tag_scope) == ST_MODULE && STYPEG(host_scope) != ST_MODULE)
8302 host_scope = SCOPEG(host_scope);
8303 if (tag_scope != host_scope)
8305 "Cannot extend type with PRIVATE attribute -",
SYMNAME(tag));
8325 ERR310(
"PUBLIC/PRIVATE may only appear in a MODULE scoping unit",
CNULL);
8337 ERR310(
"PUBLIC/PRIVATE may only appear in a MODULE scoping unit",
CNULL);
8346 goto add_sym_to_list;
8352 goto add_sym_to_list;
8396 "SEQUENCE must appear in a derived type definition",
CNULL);
8421 error(81, 3,
gbl.lineno,
"- illegal intent", np);
8435 error(81, 3,
gbl.lineno,
"- illegal intent in", np);
8439 error(81, 3,
gbl.lineno,
"- illegal intent", np);
8448 case ENTITY_DECL_LIST1:
8450 goto add_entity_to_list;
8454 case ENTITY_DECL_LIST2:
8483 goto entity_decl_shared;
8493 stype1 = STYPEG(
sptr);
8502 goto entity_decl_shared;
8512 stype1 = STYPEG(
sptr);
8550 error(155, 3,
gbl.lineno,
"CLASS component must be "
8551 "allocatable or pointer -",
8561 switch (STYPEG(
sptr)) {
8575 goto entity_decl_end;
8577 switch (STYPEG(
sptr)) {
8597 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY) {
8598 int dims,
idx, lbast;
8612 "Implied-shape array must have the PARAMETER attribute -",
8614 goto entity_decl_end;
8620 SCG(
sptr) != SC_DUMMY && A_TYPEG(lbast) != A_CNST) {
8622 "Implied-shape array lower bound is not constant -",
8624 goto entity_decl_end;
8627 }
else if (
DTY(DTYPEG(
sptr)) == TY_PTR &&
8630 int func_dtype =
DTY(DTYPEG(
sptr) + 1);
8632 }
else if (!USELENG(
sptr) && !LENG(
sptr)) {
8635 if (SCG(
sptr) == SC_DUMMY) {
8644 stype = STYPEG(
sptr);
8645 if (stype == ST_MEMBER) {
8648 }
else if (stype == ST_ENTRY)
8659 for (; et_bitv; et_bitv >>= 1, et_type++) {
8660 if ((et_bitv & 0x0001) == 0)
8666 if (
sptr == ST_ARRAY && ADJARRG(
sptr))
8668 "- must not be an automatic array");
8669 else if (is_member) {
8679 accessp->
oper =
' ';
8688 "- must be a deferred shape array");
8696 if (!
XBIT(54, 2) && !(
XBIT(58, 0x400000) && TARGETG(
sptr)))
8703 ALLOCATTRP(
sptr, 1);
8704 if (STYPEG(
sptr) == ST_MEMBER) {
8705 ALLOCFLDP(
DTY(ENCLDTYPEG(
sptr) + 3), 1);
8714 if (STYPEG(
sptr) == ST_MEMBER &&
DTY(
dtype) == TY_DERIVED &&
8716 FINALIZEDP(
sptr, 1);
8718 if (!(
DTY(DTYPEG(
sptr)) == TY_ARRAY && STYPEG(
sptr) == ST_MEMBER) &&
8732 if (SCG(
sptr) != SC_DUMMY)
8733 SCP(
sptr, SC_BASED);
8735 }
else if (SCG(
sptr) == SC_DUMMY) {
8739 (
DDTG(DTYPEG(
sptr)) == DT_DEFERCHAR ||
8740 DDTG(DTYPEG(
sptr)) == DT_DEFERNCHAR)) {
8741 if (SCG(
sptr) != SC_DUMMY)
8742 SCP(
sptr, SC_BASED);
8747 SCP(
sptr, SC_BASED);
8753 CONTIGATTRP(
sptr, 1);
8759 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY) {
8761 error(134, 3,
gbl.lineno,
"- array bounds not allowed with external",
8770 if (SCG(
sptr) == SC_DUMMY) {
8771 IS_PROC_DUMMYP(
sptr, 1);
8780 if (SCG(
sptr) != SC_DUMMY) {
8782 "- intent specified for nondummy argument",
SYMNAME(
sptr));
8783 }
else if (POINTERG(
sptr)) {
8784 error(134, 3,
gbl.lineno,
"- intent specified for pointer argument",
8786 }
else if (STYPEG(
sptr) == ST_PROC) {
8788 "- intent specified for dummy subprogram argument",
8797 itemp1->
ast =
gbl.lineno;
8801 stype = STYPEG(
sptr);
8818 CONTIGATTRP(
sptr, 1);
8819 if (
DTYG(DTYPEG(
sptr)) == TY_DERIVED &&
XBIT(58, 0x40000)) {
8826 "- must be a deferred shape array");
8834 if (STYPEG(
sptr) == ST_MEMBER &&
DTY(
dtype) == TY_DERIVED &&
8836 FINALIZEDP(
sptr, 1);
8838 if (!(
DTY(DTYPEG(
sptr)) == TY_ARRAY && STYPEG(
sptr) == ST_MEMBER) &&
8860 STYPEG(
sptr) == ST_MEMBER ||
DTY(DTYPEG(
sptr)) == TY_ARRAY) {
8871 (
DDTG(DTYPEG(
sptr)) == DT_DEFERCHAR ||
8872 DDTG(DTYPEG(
sptr)) == DT_DEFERNCHAR)) {
8873 if (SCG(
sptr) != SC_DUMMY)
8874 SCP(
sptr, SC_BASED);
8885 else if (stype == ST_ARRAY && (ASUMSZG(
sptr) || ADJARRG(
sptr))) {
8888 "An assumed-size array cannot have the SAVE attribute -",
8890 else if (SCG(
sptr) == SC_DUMMY)
8892 "An adjustable array cannot have the SAVE attribute -",
8896 "An automatic array cannot have the SAVE attribute -",
8901 "SAVE attribute for a BLOCK variable of a PURE subroutine" :
8902 "SAVE attribute for a local variable of a PURE subroutine",
8904 }
else if ((SCG(
sptr) == SC_NONE || SCG(
sptr) == SC_LOCAL ||
8905 SCG(
sptr) == SC_BASED) &&
8906 (stype == ST_VAR || stype == ST_ARRAY ||
8907 stype == ST_STRUCT || stype == ST_IDENT)) {
8920 if(
XBIT(58, 0x400000) && SCG(
sptr) == SC_DUMMY && ASSUMSHPG(
sptr) )
8929 else if (stype == ST_ARRAY && (ASUMSZG(
sptr) || ADJARRG(
sptr)))
8933 else if ((SCG(
sptr) == SC_NONE || SCG(
sptr) == SC_LOCAL ||
8934 SCG(
sptr) == SC_BASED) &&
8935 (stype == ST_VAR || stype == ST_ARRAY || stype == ST_STRUCT ||
8936 stype == ST_IDENT)) {
8937 if (SCG(
sptr) == SC_BASED && MIDNUMG(
sptr))
8944 SCP(
sptr, SC_LOCAL);
8956 else if (stype == ST_ARRAY && (ASUMSZG(
sptr) || ADJARRG(
sptr)))
8960 else if ((SCG(
sptr) == SC_NONE || SCG(
sptr) == SC_LOCAL ||
8961 SCG(
sptr) == SC_BASED) &&
8962 (stype == ST_VAR || stype == ST_ARRAY || stype == ST_STRUCT ||
8963 stype == ST_IDENT)) {
8964 if (SCG(
sptr) == SC_BASED && MIDNUMG(
sptr))
8974 error(280, 2,
gbl.lineno,
"BIND: allowed only in module", 0);
8979 error(155, 3,
gbl.lineno,
"Polymorphic variable"
8980 " cannot have VALUE attribute -",
8986 "Multi-CHARACTER strings can not have the VALUE attribue - ",
8989 PASSBYVALP(
sptr, 1);
8990 PASSBYREFP(
sptr, 0);
9009 PROTECTEDP(
sptr, 1);
9015 "derived type parameter must be an INTEGER -",
SYMNAME(
sptr));
9024 "derived type parameter must be an INTEGER -",
SYMNAME(
sptr));
9034 if ((DTYPEG(
sptr) == DT_DEFERCHAR || DTYPEG(
sptr) == DT_DEFERNCHAR) &&
9035 (!POINTERG(
sptr) && !ALLOCATTRG(
sptr))) {
9036 error(155, 3,
gbl.lineno,
"Object with deferred character length"
9037 " (:) must be a pointer or an allocatable -",
9041 if (RESULTG(
sptr) && STYPEG(
sptr) != ST_ENTRY &&
9044 " PARAMETER attribute -",
9046 goto entity_decl_end;
9054 error(155, 3,
gbl.lineno,
"Implied-shape array must be initialized "
9056 goto entity_decl_end;
9062 goto entity_decl_end;
9066 goto entity_decl_end;
9070 if (RESULTG(
sptr) && STYPEG(
sptr) != ST_ENTRY) {
9073 " an initializer -",
9075 goto entity_decl_end;
9081 if (stype != STYPEG(
sptr) && STYPEG(
sptr) != ST_PARAM) {
9082 if (STYPEG(
sptr) == ST_VAR && stype == ST_ARRAY) {
9090 STYPEP(
sptr, ST_IDENT);
9094 if (stype == ST_ARRAY && !F90POINTERG(
sptr)) {
9095 if (POINTERG(
sptr) || MDALLOCG(
sptr) ||
9096 (ALLOCATTRG(
sptr) && STYPEG(
sptr) == ST_MEMBER)) {
9097 int dty = DTYPEG(
sptr);
9100 if (
DTY(dty) == TY_ARRAY) {
9103 if (
DTY(dty) == TY_DERIVED && SCG(
sptr) != SC_DUMMY) {
9120 SCP(
sptr, SC_BASED);
9128 goto entity_decl_end;
9140 }
else if (
DTY(DTYPEG(
sptr)) == TY_ARRAY) {
9155 if (!INITKINDG(
sptr))
9158 goto entity_decl_end;
9176 goto entity_decl_end;
9179 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY && !POINTERG(
sptr)) {
9181 error(155, 3,
gbl.lineno,
"Cannot initialize deferred-shape array",
9183 goto entity_decl_end;
9186 if (POINTERG(
sptr)) {
9194 if ((
DTY(DTYPEG(
sptr)) != TY_ARRAY || STYPEG(
sptr) != ST_MEMBER) &&
9197 STYPEG(
sptr) == ST_MEMBER ||
DTY(DTYPEG(
sptr)) == TY_ARRAY))
9201 if ((
DTY(DTYPEG(
sptr)) != TY_ARRAY || STYPEG(
sptr) != ST_MEMBER) &&
9204 STYPEG(
sptr) == ST_MEMBER ||
DTY(DTYPEG(
sptr)) == TY_ARRAY))
9210 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY) {
9216 goto entity_decl_end;
9219 "Shape of initializer does not match shape of",
9221 goto entity_decl_end;
9223 }
else if (POINTERG(
sptr) || ALLOCATTRG(
sptr)) {
9225 goto entity_decl_end;
9230 goto entity_decl_end;
9234 if (STYPEG(
sptr) == ST_PARAM) {
9239 }
else if (
DTY(
dtype) == TY_DERIVED && !POINTERG(
sptr)) {
9242 if (STYPEG(
sptr) == ST_IDENT || STYPEG(
sptr) == ST_UNKNOWN) {
9243 STYPEP(
sptr, ST_VAR);
9245 if (SCG(
sptr) == SC_NONE)
9246 SCP(
sptr, SC_LOCAL);
9267 }
else if (
DTY(dt_dtype + 5) && SCOPEG(
sptr) &&
9277 if (POINTERG(
sptr)) {
9325 goto entity_id_shared;
9364 if (STYPEG(
sptr) != ST_UNKNOWN)
9367 STYPEP(
sptr, ST_MEMBER);
9399 if (
DTY(
d) == TY_DERIVED &&
DTY(
d + 3) && DISTMEMG(
DTY(
d + 3))) {
9409 if (stype == ST_ARRAY) {
9418 "- deferred shape array must have the POINTER "
9419 "or ALLOCATABLE attribute in a derived type");
9423 int bndast, badArray;
9425 for (badArray =
i = 0;
i < numdim;
i++) {
9439 for (badArray =
i = 0;
i < numdim;
i++) {
9466 }
else if (A_TYPEG(bndast) != A_ID &&
9467 A_TYPEG(bndast) != A_CNST) {
9484 "- array must have constant bounds "
9485 "in a derived type");
9493 if (
DTY(
d) == TY_DERIVED &&
DTY(
d + 3) && DISTMEMG(
DTY(
d + 3))) {
9504 "SEQUENCE must be set for nested derived type",
9509 error(155, 3,
gbl.lineno,
"Derived type component must "
9510 "have the POINTER attribute -",
9515 error(155, 4,
gbl.lineno,
"Derived type has not been declared -",
9534 if (SCG(
sptr) == SC_DUMMY ||
9537 if (PASSBYVALG(
sptr)) {
9538 error(155, 3,
gbl.lineno,
"Polymorphic variable cannot have VALUE"
9546 "Polymorphic variable cannot be declared "
9547 "with a BIND(C) derived type - ",
9552 "Polymorphic variable cannot be declared "
9553 "with a SEQUENCE derived type - ",
9559 error(155, 3,
gbl.lineno,
"Polymorphic variable must be a pointer, "
9560 "allocatable, or dummy object - ",
9566 SCG(
sptr) != SC_DUMMY && !FVALG(
sptr) &&
9570 if (STYPEG(
sptr) == ST_PROC && SCOPEG(
sptr) &&
9578 stype1 = STYPEG(
sptr);
9583 if (stype == ST_ARRAY) {
9591 stype1 = ST_UNKNOWN;
9592 }
else if (stype1 == ST_ENTRY) {
9593 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY) {
9597 }
else if (stype1 == ST_ARRAY) {
9606 assert(dtypeset,
"semant: dtype was not set",
dtype, 3);
9622 }
else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT &&
9637 stype1 = ST_UNKNOWN;
9651 if (stype1 == ST_UNKNOWN ||
9652 (stype == ST_ARRAY && (stype1 == ST_IDENT || stype1 == ST_VAR))) {
9654 STYPEP(
sptr, ST_IDENT);
9661 if (stype == ST_ARRAY) {
9665 if (SCG(
sptr) != SC_DUMMY)
9668 if (SCG(
sptr) != SC_NONE && SCG(
sptr) != SC_DUMMY &&
9669 SCG(
sptr) != SC_BASED)
9676 if (SCG(
sptr) != SC_NONE && SCG(
sptr) != SC_DUMMY &&
9677 SCG(
sptr) != SC_BASED)
9690 if (SCG(
sptr) == SC_CMBLK)
9692 if (SCG(
sptr) == SC_DUMMY) {
9696 ASSUMRANKP(
sptr, 1);
9698 if (!
XBIT(54, 2) && !(
XBIT(58, 0x400000) && TARGETG(
sptr)))
9707 if (!
XBIT(54, 2) && !(
XBIT(58, 0x400000) && TARGETG(
sptr)))
9715 }
else if (stype == ST_ARRAY) {
9716 if (stype1 == ST_ENTRY) {
9719 interr(
"semant1: trying to set data type of ST_ENTRY",
sptr, 3);
9727 if (RESULTG(
sptr)) {
9728 assert(dtypeset,
"semant: dtype was not set (2)",
dtype, 3);
9741 if (!
XBIT(54, 2) && !(
XBIT(58, 0x400000) && TARGETG(
sptr)))
9749 if (RESULTG(
sptr) && STYPEG(
sptr) != ST_ENTRY) {
9797 error(155, 3,
gbl.lineno,
"A generic specifier cannot be present in an",
9798 "ABSTRACT INTERFACE");
9806 case BEGININTERFACE1:
9812 case BEGININTERFACE2:
9817 "Interface-block may not appear in a"
9818 " module after the CONTAINS statement unless it is inside"
9819 " a module subprogram",
9848 if (STYPEG(
sptr) == ST_TYPEDEF) {
9855 }
else if (STYPEG(
sptr) && STYPEG(
sptr) != ST_USERGENERIC) {
9861 if (STYPEG(oldsptr) != ST_TYPEDEF) {
9865 int oldsptr2 = oldsptr;
9866 for (; STYPEG(oldsptr2) == ST_ALIAS; oldsptr2 = SYMLKG(oldsptr2))
9868 if (STYPEG(oldsptr2) == ST_PROC && CLASSG(oldsptr2) &&
9873 if (STYPEG(oldsptr2) == ST_TYPEDEF)
9876 if (STYPEG(oldsptr) == ST_TYPEDEF) {
9877 GTYPEP(
sptr, oldsptr);
9883 GTYPEP(
sptr, oldsptr);
9889 STYPEP(
sptr, ST_USERGENERIC);
9892 IGNOREP(oldsptr,
TRUE);
9958 error(155, 3,
gbl.lineno,
"(FORMATTED) or (UNFORMATTED) "
9959 "must follow defined READ",
9969 error(155, 3,
gbl.lineno,
"(FORMATTED) or (UNFORMATTED) "
9970 "follow defined WRITE",
9975 error(155, 3,
gbl.lineno,
"Invalid generic specification -",
9987 "Generic name for INTERFACE statement "
9988 "does not match generic name for END INTERFACE ",
10007 STYPEP(
sptr, STYPEG(sptr1));
10039 "Predefined intrinsic operator loses intrinsic property -", anm);
10057 case INTRINSIC_OP1:
10064 case INTRINSIC_OP2:
10071 case INTRINSIC_OP3:
10079 case INTRINSIC_OP4:
10084 case INTRINSIC_OP5:
10092 case INTRINSIC_OP6:
10100 case INTRINSIC_OP7:
10108 case INTRINSIC_OP8:
10116 case INTRINSIC_OP9:
10124 case INTRINSIC_OP10:
10131 case INTRINSIC_OP11:
10175 case END_INTERFACE1:
10177 goto end_interface_shared;
10181 case END_INTERFACE2:
10183 end_interface_shared:
10215 case MODULE_PROCEDURE_STMT1:
10217 goto module_procedure_stmt;
10218 case MODULE_PROCEDURE_STMT2:
10220module_procedure_stmt:
10250 "- MODULE PROCEDURE requires a generic INTERFACE",
CNULL);
10261 if (STYPEG(
sptr) != ST_PROC)
10262 error(195, 3,
gbl.lineno,
"- Unable to access module procedure",
10264 if (ENCLFUNCG(
sptr) == 0 || STYPEG(ENCLFUNCG(
sptr)) != ST_MODULE) {
10282 if (STYPEG(SCOPEG(
sptr)) == ST_MODULE) {
10286 INMODULEP(
sptr, 1);
10289 error(280, 2,
gbl.lineno,
"BIND: allowed only in module", 0);
10301 case PROCEDURE_STMT1:
10303 goto procedure_stmt;
10304 case PROCEDURE_STMT2:
10308 error(155, 3,
gbl.lineno,
"PROCEDURE must appear in an INTERFACE",
CNULL);
10315 error(195, 3,
gbl.lineno,
"- PROCEDURE requires a generic INTERFACE",
10326 if (STYPEG(
sptr) != ST_PROC) {
10327 if (STYPEG(
sptr) == ST_USERGENERIC) {
10398 goto common_module;
10405 goto common_module;
10415 if (
XBIT(68, 0x1)) {
10417 static const char *names[] = {
"ieee_exceptions",
"ieee_arithmetic",
10418 "cudafor",
"openacc",
10419 "accel_lib",
NULL};
10421 for (
j = 0; names[
j]; ++
j) {
10429 error(4, 3,
gbl.lineno,
"MODULE cannot contain USE of itself -",
10434 STYPEG(
sptr) != ST_MODULE) {
10438 if (nsptr > 0 && (nsptr <
stb.
firstusym || STYPEG(nsptr) == ST_UNKNOWN ||
10439 STYPEG(nsptr) == ST_MODULE)) {
10452 case MODULE_NATURE1:
10458 case MODULE_NATURE2:
10484 if (sptr1 ==
sptr || NMPTRG(
sptr) != NMPTRG(sptr1))
10520 case RENAME_OPERATOR1:
10526 case RENAME_OPERATOR2:
10597 if (STYPEG(
sptr) == ST_OPERATOR && INKINDG(
sptr)) {
10602 if (STYPEG(
sptr) == ST_OPERATOR && INKINDG(
sptr)) {
10614 case ONLY_OPERATOR1:
10621 case ONLY_OPERATOR2:
10627 case ONLY_OPERATOR3:
10636 goto add_tp_to_list;
10673 case DEC_DECLARATION1:
10679 if (STYPEG(
sptr) != ST_CMBLK)
10682 for (da_bitv =
dec_attr.
exist; da_bitv; da_bitv >>= 1, da_type++) {
10683 if ((da_bitv & 1) == 0)
10688#if defined(TARGET_WIN)
10700 if (STYPEG(
sptr) == ST_PROC || STYPEG(
sptr) == ST_ENTRY) {
10712 if ((STYPEG(
sptr) == ST_ENTRY) || (STYPEG(
sptr) == ST_PROC))
10716 PASSBYVALP(
sptr, 0);
10717 PASSBYREFP(
sptr, 1);
10719 if (CFUNCG(
sptr)) {
10727 if ((STYPEG(
sptr) == ST_ENTRY) || (STYPEG(
sptr) == ST_PROC))
10731 PASSBYVALP(
sptr, 1);
10732 PASSBYREFP(
sptr, 0);
10748 DECORATEP(
sptr, 1);
10752 NOMIXEDSTRLENP(
sptr, 1);
10756 switch (STYPEG(
sptr)) {
10768 if ((SCG(
sptr) == SC_CMBLK && !HCCSYMG(CMBLKG(
sptr))) ||
10769 SCOPEG(
sptr) !=
gbl.currmod) {
10771 "- ATTRIBUTES items must be global");
10781 "- must be defined for ATTRIBUTES");
10794 case DEC_DECLARATION2:
10798 case DEC_DECLARATION3:
10816 error(134, 3,
gbl.lineno,
"- duplicate",
da[da_type].name);
10818 error(134, 3,
gbl.lineno,
"- conflict with",
da[da_type].name);
10830 if (strcmp(np,
"alias") == 0) {
10831 error(155, 2,
gbl.lineno,
"Unrecognized directive: ATTRIBUTES", np);
10832 }
else if (strcmp(np,
"c") == 0)
10834 else if (strcmp(np,
"stdcall") == 0)
10846 else if (
sem_strcmp(np,
"nomixed_str_len_arg") == 0)
10849 error(155, 2,
gbl.lineno,
"Unrecognized directive: ATTRIBUTES", np);
10857 if (strcmp(np,
"alias") == 0) {
10861 error(155, 2,
gbl.lineno,
"Unrecognized directive: ATTRIBUTES", np);
10876 if (
i >=
'a' &&
i <=
'z')
10877 *np =
i + (
'A' -
'a');
10888 case CMN_IDENT_LIST1:
10890 goto add_cmn_to_list;
10894 case CMN_IDENT_LIST2:
10923 if (STYPEG(
sptr) == ST_CMBLK) {
10933 case PRAGMA_DECLARATION1:
10938 case PRAGMA_DECLARATION2:
10941 "IGNORE_TKR can only appear in an interface body"
10942 " or a module procedure",
10949 case PRAGMA_DECLARATION3:
10954 case PRAGMA_DECLARATION4:
10955#if defined(MVDESCP)
10958 MVDESCP(
gbl.currsub, 1);
10971 i = DPDSCG(
gbl.currsub);
11007 if (SCG(
sptr) == SC_DUMMY)
11011 "- IGNORE_TKR specified for nondummy argument",
SYMNAME(
sptr));
11061 error(155, 3,
gbl.lineno,
"Illegal IGNORE_TKR specifier",
CNULL);
11077 DFLTP(
gbl.currsub, 1);
11088 if (STYPEG(
sptr) == ST_ENTRY || STYPEG(
sptr) == ST_PROC) {
11101 error(155, 3,
gbl.lineno,
"IMPORT can only appear in an interface body",
11152 case IMPORT_NAME_LIST1:
11157 case IMPORT_NAME_LIST2:
11194 case PROCEDURE_DECLARATION1:
11213 proc_interf_sptr = 0;
11225 proc_interf_sptr = 0;
11232 case OPT_PROC_ATTR1:
11237 case OPT_PROC_ATTR2:
11247 case PROC_ATTR_LIST1:
11251 case PROC_ATTR_LIST2:
11253 error(134, 3,
gbl.lineno,
"- duplicate",
et[et_type].name);
11255 if (
ET_B(et_type) &
11258 error(134, 3,
gbl.lineno,
et[et_type].name,
"for procedure component");
11262 if (
ET_B(et_type) &
11266 error(134, 3,
gbl.lineno,
et[et_type].name,
"for procedure");
11340 case PROC_DCL_LIST1:
11345 case PROC_DCL_LIST2:
11353 goto proc_dcl_init;
11362 goto proc_dcl_shared;
11386 proc_interf_sptr >
NOSYM && SCG(
sptr) != SC_DUMMY) {
11393 if (!POINTERG(sym) && SCG(sym) == SC_DUMMY &&
11401 proc_interf_sptr >
NOSYM && SCG(
sptr) == SC_DUMMY) {
11402 IS_PROC_DUMMYP(
sptr, 1);
11404 if (POINTERG(
sptr)) {
11407 if (!IS_PROC_DUMMYG(
sptr) && IS_INTERFACEG(proc_interf_sptr) &&
11408 !IS_PROC_PTR_IFACEG(proc_interf_sptr)) {
11425 sprintf(
buf,
"%s$iface",
SYMNAME(proc_interf_sptr));
11440 if (sym <=
NOSYM) {
11446 IS_PROC_PTR_IFACEP(sym, 1);
11448 proc_interf_sptr = sym;
11461 stype = STYPEG(
sptr);
11464 if (stype == ST_PROC) {
11466 goto proc_decl_end;
11471 SCP(
sptr, SC_BASED);
11473 if (A_TYPEG(
ast) == A_FUNC) {
11478 goto proc_decl_end;
11500 if (A_TYPEG(
ast) == A_FUNC) {
11505 goto proc_decl_end;
11515 }
else if (POINTERG(
sptr)) {
11522 if (STYPEG(
sptr) != ST_ENTRY && STYPEG(
sptr) != ST_MEMBER &&
11535 case TYPE_BOUND_PROCEDURE1:
11546 "Specifying a deferred type bound procedure in "
11547 "non-abstract type",
11552 "Specifying a deferred type bound procedure without"
11553 " an interface-name in",
11571 SCP(
sptr, SC_DUMMY);
11595 case OPT_INTERFACE_NAME1:
11600 case OPT_INTERFACE_NAME2:
11610 case OPT_BINDING_ATTR_LIST1:
11617 case OPT_BINDING_ATTR_LIST2:
11628 case BINDING_ATTR_LIST1:
11631 error(134, 3,
gbl.lineno,
"- duplicate",
"PASS");
11634 error(134, 3,
gbl.lineno,
"- duplicate",
"NOPASS");
11637 error(134, 3,
gbl.lineno,
"- duplicate",
"NON_OVERRIDABLE");
11640 error(134, 3,
gbl.lineno,
"- duplicate",
"DEFERRED");
11643 error(134, 3,
gbl.lineno,
"- duplicate",
"PRIVATE");
11646 error(134, 3,
gbl.lineno,
"- duplicate",
"PUBLIC");
11653 error(155, 3,
gbl.lineno,
"PASS and NOPASS may not appear "
11654 "in same type bound procedure",
11658 error(155, 3,
gbl.lineno,
"DEFERRED and NON_OVERRIDABLE "
11659 "may not appear in same type bound procedure",
11663 error(155, 3,
gbl.lineno,
"PRIVATE and PUBLIC "
11664 "may not appear in same type bound procedure",
11676 case BINDING_ATTR_LIST2:
11685 case BINDING_ATTR1:
11696 }
else if (
sem_strcmp(np,
"non_overridable") == 0) {
11698 }
else if (
sem_strcmp(np,
"deferred") == 0) {
11700 }
else if (
sem_strcmp(np,
"private") == 0) {
11711 case BINDING_ATTR2:
11729 case BINDING_NAME_LIST1:
11734 case BINDING_NAME_LIST2:
11741 case BINDING_NAME1:
11743 goto binding_name_common;
11747 case BINDING_NAME2: {
11748 SPTR tag, sptr3, sptr2, orig_sptr;
11749 char *
name, *name_cpy, *name_cpy2;
11760 binding_name_common:
11770 if (SEPARATEMPG(sptr2))
11771 TBP_BOUND_TO_SMPP(sptr2,
TRUE);
11777 parent = DTYPEG(PARENTG(tag));
11783 strcpy(name_cpy,
SYMNAME(BINDG(sym)));
11784 name = strstr(name_cpy,
"$tbp");
11788 vtoff = VTOFFG(BINDG(sym));
11789 VTOFFP(
sptr, vtoff);
11795 if (STYPEG(sptr2) && STYPEG(sptr2) != ST_PROC) {
11799 if (STYPEG(
sptr) > 0) {
11806 STYPEP(sptr3, STYPEG(
sptr));
11807 IGNOREP(sptr3, IGNOREG(
sptr));
11809 parent = DTYPEG(PARENTG(tag));
11813 if (CCSYMG(sym) && BINDG(sym)) {
11817 strcpy(name_cpy,
SYMNAME(BINDG(sym)));
11818 name = strstr(name_cpy,
"$tbp");
11825 name = strstr(name_cpy2,
"$tbp");
11829 if (strcmp(name_cpy, name_cpy2) == 0) {
11830 vtoff = VTOFFG(BINDG(sym));
11831 VTOFFP(
sptr, vtoff);
11841 if (STYPEG(orig_sptr) != ST_PD && STYPEG(
sptr) != ST_PROC) {
11845 if (STYPEG(orig_sptr) != ST_PARAM)
11853 VTOFFP(
sptr, vtoff);
11856 if (!VTOFFG(tag) && PARENTG(tag) && VTOFFG(PARENTG(tag))) {
11857 VTOFFP(tag, VTOFFG(PARENTG(tag)));
11859 if (!VTOFFG(
sptr) && !VTOFFG(tag) &&
11862 VTOFFP(
sptr, vtoff + 1);
11863 VTOFFP(tag, vtoff + 1);
11866 if (!VTOFFG(
sptr)) {
11870 VTOFFP(tag, VTOFFG(tag) + 1);
11871 VTOFFP(
sptr, VTOFFG(tag));
11878 if (!TBPLNKG(
sptr)) {
11891 if (!STYPEG(
sptr) ||
11892 (orig_sptr >
NOSYM &&
11893 HASHLKG(
sptr) == orig_sptr &&
11894 STYPEG(orig_sptr))) {
11902 case ACCEL_DECL_BEGIN1:
11909 case ACCEL_DECL_LIST1:
11914 case ACCEL_DECL_LIST2:
11920 case ACCEL_DECL_ATTR1:
11925 case ACCEL_DECL_ATTR2:
11930 case ACCEL_DECL_ATTR3:
11935 case ACCEL_DECL_ATTR4:
11940 case ACCEL_DECL_ATTR5:
11945 case ACCEL_DECL_ATTR6:
11950 case ACCEL_DECL_ATTR7:
11955 case ACCEL_DECL_ATTR8:
11960 case ACCEL_DECL_ATTR9:
11965 case ACCEL_DECL_ATTR10:
11970 case ACCEL_DECL_ATTR11:
11975 case ACCEL_DECL_ATTR12:
11980 case ACCEL_DECL_ATTR13:
11985 case ACCEL_DECL_ATTR14:
11990 case ACCEL_DECL_ATTR15:
11995 case ACCEL_DECL_ATTR16:
12002 case ACCEL_DECL_DATA_LIST1:
12003 accel_decl_data_list1:
12013 case ACCEL_DECL_DATA_LIST2:
12014 accel_decl_data_list2:
12026 case ACCEL_DECL_DATA1:
12030 switch (STYPEG(
sptr)) {
12037 error(155, 3,
gbl.lineno,
"Unknown symbol used in data clause -",
12046 case ACCEL_DECL_DATA2:
12057 case ACCEL_DECL_DATA3:
12063 case ACCEL_DECL_DATA4:
12074 case ACCEL_MDECL_DATA1:
12075 goto accel_decl_data1;
12079 case ACCEL_MDECL_DATA2:
12080 goto accel_decl_data2;
12084 case ACCEL_MDECL_DATA3:
12092 case ACCEL_MDECL_DATA_LIST1:
12093 goto accel_decl_data_list1;
12097 case ACCEL_MDECL_DATA_LIST2:
12098 goto accel_decl_data_list2;
12104 case ACCEL_DECL_SUB_LIST1:
12114 case ACCEL_DECL_SUB_LIST2:
12126 case GENERIC_TYPE_PROCEDURE1:
12151 if (!VTOFFG(
sptr)) {
12152 int vt = VTOFFG(tag);
12153 if (!vt && PARENTG(tag) && VTOFFG(PARENTG(tag))) {
12158 vt = VTOFFG(PARENTG(tag));
12162 VTOFFP(
sptr, vt + 1);
12163 if (STYPEG(
sptr) == ST_OPERATOR) {
12184 case OPT_GEN_ACCESS_SPEC1:
12186 goto gen_access_spec_common;
12190 case OPT_GEN_ACCESS_SPEC2:
12192 gen_access_spec_common:
12207 case GEN_ACCESS_SPEC1:
12215 error(155, 3,
gbl.lineno,
"Invalid access specifier in generic"
12216 " type bound procedure",
12224 case ACCEL_DECL_SUB1:
12239 case ACCEL_DECL_SUB2:
12250 case ACCEL_ROUTINE_LIST1:
12255 case ACCEL_ROUTINE_LIST2:
12260 case ACCEL_ROUTINE_LIST3:
12265 case ACCEL_ROUTINE_LIST4:
12270 case ACCEL_ROUTINE_LIST5:
12275 case ACCEL_ROUTINE_LIST6:
12281 case ACCEL_ROUTINE_LIST7:
12287 case ACCEL_ROUTINE_LIST8:
12293 case ACCEL_ROUTINE_LIST9:
12299 case ACCEL_ROUTINE_LIST10:
12304 case ACCEL_ROUTINE_LIST11:
12311 case DEVTYPE_LIST1:
12316 case DEVTYPE_LIST2:
12323 case DEVTYPE_ATTR1:
12328 case DEVTYPE_ATTR2:
12335 case GENERIC_BINDING1:
12348 case GENERIC_BINDING_NAME1:
12355 case GENERIC_BINDING_LIST1:
12357 goto shared_generic_binding;
12362 case GENERIC_BINDING_LIST2:
12364 shared_generic_binding:
12382 case FINAL_SUBROUTINES1:
12385 "a FINAL subroutine statement can only appear"
12386 " within the type bound procedure part of a derived type",
12402 goto shared_final_sub;
12428 case MP_DECL_BEGIN1:
12436#ifdef OMP_OFFLOAD_LLVM
12447#ifdef OMP_OFFLOAD_LLVM
12464 case DECLARERED_BEGIN1:
12466 error(155, 2,
gbl.lineno,
"Unimplemented feature - DECLARE REDUCTION",
12476 case DECLARE_REDUCTION1:
12493 interr(
"semant1:bad rednum", rednum, 3);
12511 STYPEP(sym, STYPEG(orig_sym));
12512 SCP(sym, SCG(orig_sym));
12513 SCOPEP(sym, SC_NONE);
12514 ASSOC_PTRP(sym,
sptr);
12515 PTR_TARGETP(sym, orig_sym);
12516 PTR_TARGETP(
sptr, orig_sym);
12520 if (STYPEG(SCOPEG(orig_sym)) == ST_MODULE) {
12521 INMODULEP(orig_sym, 1);
12528 switch (STYPEG(
sptr)) {
12531 STYPEP(
sptr, ST_VAR);
12535 if (SCG(
sptr) == SC_NONE)
12536 SCP(
sptr, SC_LOCAL);
12559 if (SCG(
sptr) == SC_DUMMY) {
12612 for (
i = PARAMCTG(
gbl.currsub);
i > 0;
i--)
12613 if ((
arg = *dscptr++)) {
12615 switch (STYPEG(
arg)) {
12637 STYPEP(
gbl.currsub, ST_PROC);
12641 TYPDP(
gbl.currsub, 1);
12642 IS_PROC_DUMMYP(
gbl.currsub, 1);
12722 ASSUMLENP(
sptr, 1);
12729 static int kind0, kind1, propagate0, propagate1;
12730 static INT len0, len1;
12735 propagate0 =
lenspec[0].propagated;
12738 propagate1 =
lenspec[1].propagated;
12750 lenspec[0].propagated = propagate0;
12753 lenspec[1].propagated = propagate1;
12757#ifdef FLANG_SEMANT_UNUSED
12759get_actype(
SST *stkptr,
int ivl)
12771 ADJARRP(entry, ADJARRG(
sptr));
12772 ADJLENP(entry, ADJLENG(
sptr));
12773 ALLOCP(entry, ALLOCG(
sptr));
12774 ASSUMSHPP(entry, ASSUMSHPG(
sptr));
12775 ASUMSZP(entry, ASUMSZG(
sptr));
12776 DCLDP(entry, DCLDG(
sptr));
12777 DTYPEP(entry, DTYPEG(
sptr));
12778 POINTERP(entry, POINTERG(
sptr));
12779 F90POINTERP(entry, F90POINTERG(
sptr));
12780 SEQP(entry, SEQG(
sptr));
12783 if (POINTERG(
sptr)) {
12785 if (
dtype == DT_ASSCHAR ||
dtype == DT_ASSNCHAR) {
12787 "Function result cannot be assumed-length character pointer -",
12790 POINTERP(entry,
FALSE);
12797 "Function result cannot be assumed-length character array -",
12809 if (RESULTG(
sptr)) {
12815 if (STYPEG(
e) == ST_ENTRY || STYPEG(
e) == ST_PROC) {
12816 if (FVALG(
e) ==
sptr)
12823 if (STYPEG(
e) == ST_ENTRY || STYPEG(
e) == ST_PROC) {
12824 if (FVALG(
e) ==
sptr)
12832 if (FVALG(
e) ==
sptr)
12874 if (keep_implicit) {
12889 if (UNAMEG(
gbl.currsub)) {
12931 if (
gbl.currsub == 0) {
12958 }
else if (
gbl.rutype != rutype) {
12971 return "SUBROUTINE";
12975 return "PROCEDURE";
12979 return "BLOCKDATA";
12992 "only applicable for non-internal subprogram", 0,
ERR_Severe);
12996 STYPEP(new_sptr, ST_IDENT);
13028 if (now && settype && DCLDG(oldsptr)) {
13029 DTYPEP(
sptr, DTYPEG(oldsptr));
13045 if (func_result >
NOSYM) {
13051 if (NMPTRG(
sptr) == NMPTRG(func_result) && STYPEG(
sptr) == ST_PROC &&
13052 FVALG(
sptr) == func_result) {
13055 if (NMPTRG(
sptr) == NMPTRG(func_result) && STYPEG(
sptr) == ST_ALIAS &&
13056 STYPEG(SYMLKG(
sptr)) == ST_PROC &&
13057 SCOPEG(SYMLKG(
sptr)) == SCOPEG(func_result)) {
13065 if (STYPEG(
sptr) == ST_ALIAS) {
13066 fval = FVALG(SYMLKG(
sptr));
13068 fval = FVALG(
sptr);
13071 STYPEP(fval, ST_UNKNOWN);
13072 IGNOREP(fval,
TRUE);
13073 HIDDENP(fval,
TRUE);
13086 SCP(func_result, SC_DUMMY);
13087 RESULTP(func_result,
TRUE);
13090 DTYPEP(
sptr, DTYPEG(func_result));
13091 ADJLENP(
sptr, ADJLENG(func_result));
13092 DCLDP(
sptr, DCLDG(func_result));
13093 FVALP(
sptr, func_result);
13097 if (SCG(
sptr) != SC_NONE)
13110 if (func_result >
NOSYM) {
13116 SCP(func_result, SC_DUMMY);
13117 RESULTP(func_result,
TRUE);
13118 return func_result;
13121 SCP(
sptr, SC_DUMMY);
13135 switch (STYPEG(
sptr)) {
13142 if (RESULTG(
sptr)) {
13144 "- you must specify the RESULT name");
13150 if (!DCLDG(
sptr)) {
13177 switch (STYPEG(
sptr)) {
13181 switch (SCG(
sptr)) {
13184 sptr2 = SCOPEG(
sptr);
13187 if (STYPEG(sptr2) == ST_ALIAS)
13188 sptr2 = SYMLKG(sptr2);
13189 if (sptr2 ==
gbl.currsub) {
13232 CONVAL1P(param_sptr, conval);
13233 if (
dtype == DT_ASSCHAR ||
dtype == DT_ASSNCHAR ||
dtype == DT_DEFERCHAR ||
13234 dtype == DT_DEFERNCHAR)
13235 DTYPEP(param_sptr, DTYPEG(CONVAL1G(param_sptr)));
13236 alias =
mk_cval1(conval, (
int)DTYPEG(param_sptr));
13244 A_ALIASP(
ast, alias);
13251 int sdtype = DTYPEG(
sptr);
13252 int ndtype = init_acl->
dtype;
13254 if (
DTY(ndtype) == TY_ARRAY)
13255 ndtype =
DTY(ndtype + 1);
13257 if (
DTY(sdtype) == TY_ARRAY) {
13259 ndtype =
get_type(3, TY_ARRAY, ndtype);
13260 DTY(ndtype + 2) =
DTY(sdtype + 2);
13262 DTYPEP(
sptr, ndtype);
13283 sdtype = DTYPEG(
sptr);
13284 if (
DDTG(sdtype) == DT_ASSCHAR ||
DDTG(sdtype) == DT_ASSNCHAR ||
13285 DDTG(sdtype) == DT_DEFERCHAR ||
DDTG(sdtype) == DT_DEFERNCHAR) {
13292 sdtype = DTYPEG(
sptr);
13293 if (
DDTG(sdtype) == DT_ASSCHAR ||
DDTG(sdtype) == DT_ASSNCHAR ||
13294 DDTG(sdtype) == DT_DEFERCHAR ||
DDTG(sdtype) == DT_DEFERNCHAR) {
13300 sdtype = DTYPEG(
sptr);
13301 if (
DDTG(sdtype) == DT_ASSCHAR ||
DDTG(sdtype) == DT_ASSNCHAR ||
13302 DDTG(sdtype) == DT_DEFERCHAR ||
DDTG(sdtype) == DT_DEFERCHAR) {
13308 (
DDTG(DTYPEG(
sptr)) == DT_ASSCHAR ||
13309 DDTG(DTYPEG(
sptr)) == DT_ASSNCHAR)) {
13317 if ((STYPEG(
sptr) == ST_ARRAY) && SCG(
sptr) == SC_NONE &&
13319 STYPEP(
sptr, ST_PARAM);
13322 }
else if (STYPEG(
sptr) == ST_VAR &&
DTY(DTYPEG(
sptr)) == TY_ARRAY &&
13330 STYPEP(
sptr, ST_PARAM);
13337 STYPEP(
sptr, ST_PARAM);
13342 STYPEP(
sptr, ST_PARAM);
13348 if (SCG(
sptr) != SC_NONE) {
13357 }
else if (
DTY(
dtype) == TY_ARRAY) {
13361 "- a named constant array must have constant extents");
13381 int lb1, ub1, lb2, ub2,
zbase;
13383 if (ndim1 != ndim2) {
13384 error(155, 3,
gbl.lineno,
"Implied-shape array must be initialized "
13385 "with an array of the same rank -",
SYMNAME(
sptr));
13390 for (
i = 0;
i < ndim1;
i++) {
13398 ub1 = ub2 - lb2 + lb1;
13417 STYPEP(sptr1, ST_ARRAY);
13424 sdtype = DTYPEG(
sptr);
13425 if (
DDTG(sdtype) == DT_ASSCHAR ||
DDTG(sdtype) == DT_ASSNCHAR ||
13426 DDTG(sdtype) == DT_DEFERCHAR ||
DDTG(sdtype) == DT_DEFERNCHAR) {
13482 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY)
13496 if (DINITG(
sptr) &&
DTY(td_dtype) == TY_DERIVED && !SAVEG(
sptr))
13507 DTYPE td_dtype = DTYPEG(td_sptr);
13519 td_aclp->
sptr = td_sptr;
13520 td_aclp->
dtype = td_dtype;
13522 aclpp = &td_aclp->
subc;
13524 for (fld_sptr =
DTY(td_dtype + 1); fld_sptr >
NOSYM;
13525 fld_sptr = SYMLKG(fld_sptr)) {
13527 DTYPE fld_dtype = DTYPEG(fld_sptr);
13533 for (
sptr = td_sptr;
13537 if (
sptr == (*aclpp)->sptr) {
13539 aclpp = &(*aclpp)->
next;
13544 if (
DTY(fld_dtype) == TY_DERIVED && ALLOCFLDG(
sptr)) {
13547 }
else if (ALLOCATTRG(fld_sptr)) {
13551 aclp->
sptr = MIDNUMG(fld_sptr);
13552 aclp->
next = *aclpp;
13554 aclpp = &aclp->
next;
13568 snprintf(
buf,
sizeof buf,
"Attribute '%s' cannot be applied to symbol", att);
13569 buf[
sizeof buf - 1] =
'\0';
13577 if (dtsptr && dtsptr !=
DTY(retdtype + 3)) {
13578 DTYPEP(
gbl.currsub, DTYPEG(dtsptr));
13579 DTYPEP(FVALG(
gbl.currsub), DTYPEG(dtsptr));
13582 "Function return type has not been declared",
CNULL);
13583 DTYPEP(
gbl.currsub, DTYPEG(dtsptr));
13584 DTYPEP(FVALG(
gbl.currsub), DTYPEG(dtsptr));
13602 switch (A_TYPEG(
ast)) {
13613 tmp_ast1 = tmp_ast1 ? tmp_ast1 : A_LOPG(
ast);
13625 if (tmp_ast1 || tmp_ast2) {
13626 tmp_ast1 = tmp_ast1 ? tmp_ast1 : A_LOPG(
ast);
13627 tmp_ast2 = tmp_ast2 ? tmp_ast2 : A_ROPG(
ast);
13628 newast =
mk_member(tmp_ast1, tmp_ast2, A_DTYPEG(
ast));
13640 if (tmp_ast1 || tmp_ast2) {
13641 tmp_ast1 = tmp_ast1 ? tmp_ast1 : A_LOPG(
ast);
13642 tmp_ast2 = tmp_ast2 ? tmp_ast2 : A_ROPG(
ast);
13665 if (newsptr !=
sptr) {
13666 if (STYPEG(newsptr) == ST_CONST) {
13669 }
else if (STYPEG(newsptr) == ST_PARAM) {
13692 if (A_ALIASG(
ast)) {
13693 *dtyp = A_DTYPEG(
ast);
13697 switch (A_TYPEG(
ast)) {
13699 *dtyp = A_DTYPEG(
ast);
13709 *dtyp = A_DTYPEG(
ast);
13717 *dtyp = A_DTYPEG(
ast);
13738 int sav_gbl_lineno =
gbl.lineno;
13750 dtyp = DTYPEG(
sptr);
13769 if (dtyp != DT_INT4) {
13776 DTYPEP(
gbl.currsub, dtyp);
13777 DTYPEP(FVALG(
gbl.currsub), dtyp);
13779 DTYPEP(
sptr, dtyp);
13784 gbl.lineno = sav_gbl_lineno;
13793 int sav_gbl_lineno =
gbl.lineno;
13801 if (A_TYPEG(l_ast1) == A_CNST) {
13805 DTYPEP(
gbl.currsub, dtyp);
13806 DTYPEP(FVALG(
gbl.currsub), dtyp);
13811 DTYPEP(
gbl.currsub, dtyp);
13812 ADJLENP(
gbl.currsub, 1);
13813 DTYPEP(FVALG(
gbl.currsub), dtyp);
13814 ADJLENP(FVALG(
gbl.currsub), 1);
13818 gbl.lineno = sav_gbl_lineno;
13834 if (STYPEG(
sptr) == ST_TYPEDEF && STYPEG(SCOPEG(
sptr)) == ST_MODULE) {
13843 DTYPEP(
gbl.currsub, DTYPEG(
sptr));
13844 DTYPEP(FVALG(
gbl.currsub), DTYPEG(
sptr));
13847 "Derived type has not been declared -",
13860 int need_altname = 0;
13864 if (!
XBIT(58,0x200000)) {
13867 (STYPEG(
sptr) == ST_PROC || STYPEG(
sptr) == ST_ENTRY)) {
13875 for (b_bitv =
bind_attr.
exist; b_bitv; b_bitv >>= 1, b_type++) {
13877 if ((b_bitv & 1) == 0)
13891#if defined(TARGET_OSX)
13893 if (STYPEG(
sptr) == ST_CMBLK)
13898 if ((STYPEG(
sptr) == ST_PROC) || (STYPEG(
sptr) == ST_ENTRY)) {
13899 PASSBYREFP(
sptr, 1);
13908 if ((need_altname) && ALTNAMEG(
sptr) == 0) {
13925 for (hashval = 0; hashval <
HASHSIZE; ++hashval) {
13927 for (curr_proc = curr->
proc_list; curr_proc;) {
13928 curr_proc_next = curr_proc->
next;
13930 curr_proc = curr_proc_next;
13933 curr_next = curr->
next;
13984 for (curr_proc = curr->
proc_list; curr_proc;
13985 curr_proc = curr_proc->
next) {
14002 if (STYPEG(ident) && SCOPEG(ident) ==
gbl.currsub && SCOPEG(ident) !=
proc) {
14004 proc = SCOPEG(ident);
14010 for (curr_proc = curr->
proc_list; curr_proc; curr_proc = curr_proc->
next) {
14034 curr_proc->
next = 0;
14054 for (curr_proc = curr->
proc_list; curr_proc;
14055 curr_proc = curr_proc->
next) {
14057 curr_proc->
usecnt > 0) {
14070 switch (A_TYPEG(
ast)) {
14072 GSCOPEP(A_SPTRG(
ast), 1);
14077 prop_reqgs(A_LOPG(
ast));
14080 prop_reqgs(A_PARENTG(
ast));
14083 prop_reqgs(A_LOPG(
ast));
14084 prop_reqgs(A_ROPG(
ast));
14090fixup_ident_bounds(
int sptr)
14095 if (GSCOPEG(
sptr)) {
14103 for (
i = 0;
i < numdim; ++
i) {
14115 if (GSCOPEG(
sptr)) {
14117 GSCOPEP(SDSCG(
sptr), 1);
14120 GSCOPEP(PTRVG(
sptr), 1);
14122 if (MIDNUMG(
sptr)) {
14123 GSCOPEP(MIDNUMG(
sptr), 1);
14125 if (
DTY(DTYPEG(
sptr)) == TY_ARRAY) {
14126 fixup_ident_bounds(
sptr);
14154 if (
mem && STYPEG(
mem) == ST_MEMBER) {
14157 if (pass && DTYPEG(pass) !=
stsk->
dtype) {
14198 if (iface && !PASSG(
mem) && !NOPASSG(
mem)) {
14200 PASSP(
mem, arg_sptr);
14225 if (!PASSG(
mem) && !NOPASSG(
mem)) {
14227 PASSP(
mem, *dscptr);
14228 }
else if (PASSG(
mem)) {
14234 if (CLASSG(PASSG(
mem))) {
14237 tag = DTYPEG(PASSG(
mem));
14238 tag =
DTY(tag + 3);
14259 int paramct, dpdsc,
i;
14264 for (
i = 0;
i < paramct; ++
i) {
14271 for (hptr =
stb.
hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
14274 DTYPE d1 = DTYPEG(
sptr);
14275 DTYPE d2 = DTYPEG(hptr);
14315 if ((!iface || STYPEG(iface) == ST_UNKNOWN) && !
sem.
which_pass)
14321 if (!
gbl.currsub) {
14327 switch (STYPEG(iface)) {
14332 if (SCOPEG(iface) ==
gbl.currmod)
14345 scp = SCOPEG(iface);
14346 if (scp && (scp ==
gbl.currsub || scp == SCOPEG(
gbl.currsub)) &&
14347 !INMODULEG(iface)) {
14351 switch (STYPEG(iface)) {
14356 if (scp ==
gbl.currmod) {
14359 }
else if (scp !=
gbl.currmod && NEEDMODG(scp)) {
14364 }
else if (
gbl.currsub && scp &&
14365 (!INMODULEG(iface) || ABSTRACTG(iface))) {
14366 switch (STYPEG(iface)) {
14371 if (scp == ENCLFUNCG(
gbl.currsub)) {
14374 }
else if (scp != SCOPEG(
gbl.currsub)) {
14408 int dpdsc, paramct = 0;
14410 SPTR passed_object;
14439 if (ptr_scope && STYPEG(ptr_scope) != ST_MODULE &&
14441 (
gbl.internal <= 1 || (
gbl.internal > 1 &&
gbl.outersub != ptr_scope))) {
14448 if (internal > 1 &&
gbl.internal != internal) {
14457 DTYPEP(
proc, DTYPEG(iface));
14459 if (!STYPEG(iface)) {
14462 char *symname =
SYMNAME(iface);
14466 for (hptr =
stb.
hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
14467 if (STYPEG(hptr) == ST_PROC && strcmp(symname,
SYMNAME(hptr)) == 0) {
14476 if (!STYPEG(iface)) {
14507 (STYPEG(iface) != ST_ENTRY ||
sptr != FVALG(iface))) {
14511 switch (STYPEG(iface)) {
14513 if (RESULTG(iface))
14528 paramct = PARAMCTG(iface);
14529 dpdsc = DPDSCG(iface);
14532 if (
DTY(DTYPEG(iface)) == TY_PTR) {
14539 if (!STYPEG(iface) &&
14551 if (ELEMENTALG(orig) && !
IS_INTRINSIC(STYPEG(orig)) &&
14552 POINTERG(proc_var)) {
14557 pass_notfound =
mem && PASSG(
mem);
14558 fval = FVALG(iface);
14559 if (paramct || fval) {
14569 if (paramct &&
mem && !NOPASSG(
mem) && !PASSG(
mem)) {
14570 passed_object = *dscptr;
14572 for (
j = 0;
j < paramct;
j++) {
14576 pass_notfound =
FALSE;
14577 passed_object =
arg;
14589 DTYPEP(
proc, DTYPEG(iface));
14590 PARAMCTP(
proc, paramct);
14591 DPDSCP(
proc, dpdsc);
14593 PUREP(
proc, PUREG(iface));
14594 ELEMENTALP(
proc, ELEMENTALG(iface));
14595 CFUNCP(
proc, CFUNCG(iface));
14598 if (
mem && paramct == 0 && !NOPASSG(
mem)) {
14599 error(155, 3,
lineno,
"NOPASS attribute must be present for",
14609 if (pass_notfound) {
14610 error(155, 3,
lineno,
"Passed-object dummy argument not found -",
14613 if (passed_object && iface_state) {
14618 dt = DTYPEG(passed_object);
14619 if (
DTY(
dt) != TY_DERIVED ||
DTY(
dt + 3) == 0) {
14621 "Passed-object dummy argument must be a derived type scalar -",
14625 if (
dt != ENCLDTYPEG(
mem)) {
14627 "Incompatible passed-object dummy argument for ",
14629 }
else if (!SEQG(tdf) && !
class) {
14631 "Passed-object dummy argument is not polymorphic -",
14634 if (POINTERG(passed_object) || ALLOCATTRG(passed_object))
14635 error(155, 3,
lineno,
"Passed-object dummy argument must not be "
14636 "POINTER or ALLOCATABLE -",
14639 PASSP(
mem, passed_object);
14651 typedef struct tp {
14658 static TP *tp_queue = 0;
14659 TP *
prev, *curr, *new_tp;
14662 int prevmem, firstuse, parentuse;
14666 for (
prev = curr = tp_queue; curr;) {
14674 }
else if (flag == 1) {
14679 for (curr = tp_queue; curr; curr = curr->next) {
14680 if (curr->dtype ==
dtype && strcmp(curr->name,
c) == 0) {
14681 error(155, 3,
gbl.lineno,
"Duplicate type parameter -",
c);
14686 NEW(new_tp, TP, 1);
14687 BZERO(new_tp, TP, 1);
14690 strcpy(new_tp->name,
c);
14691 new_tp->dtype =
dtype;
14692 new_tp->offset =
offset;
14693 new_tp->next = tp_queue;
14696 }
else if (flag == 3) {
14698 parent = DTYPEG(PARENTG(tag));
14705 for (curr = tp_queue; curr; curr = curr->next) {
14706 if (curr->dtype ==
dtype) {
14709 return curr->offset;
14713 }
else if (flag == 2) {
14718 for (curr = tp_queue; curr; curr = curr->next) {
14719 if (curr->dtype == 0)
14720 curr->dtype =
dtype;
14724 parent = DTYPEG(PARENTG(tag));
14727 for (curr = tp_queue; curr; curr = curr->next) {
14728 if (curr->dtype ==
dtype) {
14732 error(155, 3,
gbl.lineno,
"Duplicate type parameter "
14733 "(in parent type) -",
14741 for (curr = tp_queue; curr; curr = curr->next) {
14742 if (curr->dtype ==
dtype) {
14746 KINDP(
mem, curr->offset);
14751 error(155, 3,
gbl.lineno,
"Missing type parameter specification -",
14760 if (!USEKINDG(
mem) && KINDG(
mem) == -1) {
14761 error(155, 3,
gbl.lineno,
"Kind type parameter component does not have "
14762 "a corresponding type parameter specifier -",
14772 firstuse = parentuse = 0;
14776 if ((POINTERG(
mem) || ALLOCATTRG(
mem)) &&
DTY(bt) == TY_DERIVED) {
14778 bt = BASETYPEG(bt);
14779 if (bt && bt == ENCLDTYPEG(
mem)) {
14791 if (PARENTG(
mem)) {
14793 }
else if (!firstuse && !LENPARMG(
mem) && USELENG(
mem)) {
14795 }
else if (firstuse && LENPARMG(
mem)) {
14796 SYMLKP(prevmem, SYMLKG(
mem));
14801 SYMLKP(
mem, SYMLKG(parentuse));
14802 SYMLKP(parentuse,
mem);
14804 mem = SYMLKG(prevmem);
14813 firstuse = parentuse = 0;
14815 if (PARENTG(
mem)) {
14817 }
else if (!firstuse && !LENPARMG(
mem) && USEKINDG(
mem) &&
14818 A_TYPEG(KINDASTG(
mem)) != A_CNST &&
14819 A_TYPEG(KINDASTG(
mem)) != A_ID) {
14821 }
else if (firstuse && KINDG(
mem) && !USEKINDG(
mem) && !KINDASTG(
mem)) {
14822 SYMLKP(prevmem, SYMLKG(
mem));
14827 SYMLKP(
mem, SYMLKG(parentuse));
14828 SYMLKP(parentuse,
mem);
14830 mem = SYMLKG(prevmem);
14851 if (A_TYPEG(
ast) == A_ID) {
14910 if (PARENTG(
mem)) {
14915 if (!USEKINDG(
mem) && KINDG(
mem) &&
14932 if (PARENTG(
mem)) {
14937 if (!USEKINDG(
mem) && !LENPARMG(
mem) && KINDG(
mem) &&
14963 if (PARENTG(
mem)) {
14993 if (PARENTG(
mem)) {
15021 if (PARENTG(
mem)) {
15049 if (PARENTG(
mem)) {
15052 if (INITKINDG(
mem) && PARMINITG(
mem) &&
15054 error(155, 3,
gbl.lineno,
"Initialization must be a constant"
15055 " expression for component",
15069 switch (A_TYPEG(
ast)) {
15124 switch (A_TYPEG(
ast)) {
15176 switch (A_TYPEG(
ast)) {
15181 if (PARENTG(
mem)) {
15193 if (DEFERLENG(
sptr))
15195 else if (ASZG(
sptr))
15221 if (PARENTG(
mem)) {
15226 if (LENPARMG(
mem) && !USEKINDG(
mem) && KINDG(
mem) &&
15242 switch (A_TYPEG(
ast)) {
15278#ifdef FLANG_SEMANT_UNUSED
15284 switch (A_TYPEG(
ast)) {
15296 A_LOPP(
ast, newast);
15300 A_LOPP(
ast, newast);
15302 A_ROPP(
ast, newast);
15319 if (PARENTG(
mem)) {
15324 if (LENPARMG(
mem) && SETKINDG(
mem) && !USEKINDG(
mem) && KINDG(
mem) &&
15341 if (A_TYPEG(ast1) != A_TYPEG(ast2))
15344 switch (A_TYPEG(ast1)) {
15351 sptr1 = A_SPTRG(ast1);
15352 sptr2 = A_SPTRG(ast2);
15353 return sptr1 == sptr2;
15379 typedef struct ptList {
15381 struct ptList *
next;
15384 static PL *pl =
NULL;
15385 PL *curr, *newpl, *
prev;
15391 for (curr = pl; curr;) {
15401 newpl->dtype =
dtype;
15407 rslt = (pl !=
NULL);
15417 typedef struct parmList {
15424 struct parmList *
next;
15427 static PL *pl =
NULL;
15428 PL *curr, *newpl, *
prev;
15436 for (curr = pl; curr;) {
15443 }
else if (flag == 1) {
15447 newpl->value =
value;
15448 newpl->name =
name;
15455 }
else if (flag == 2) {
15460 for (curr = pl; curr; curr = curr->next) {
15465 if (curr->is_defer_len) {
15467 }
else if (curr->is_assume_sz) {
15475 error(155, 3,
gbl.lineno,
"Too many type parameter specifiers",
NULL);
15483 error(155, 3,
gbl.lineno,
"Undefined type parameter", curr->name);
15495 typedef struct dtyList {
15497 struct dtyList *
next;
15500 static DL *dl =
NULL;
15501 DL *curr, *newdl, *
prev;
15508 mem_dtype = DTYPEG(
mem);
15509 if (PARENTG(
mem)) {
15511 BZERO(newdl, DL, 1);
15512 newdl->dtype =
dtype;
15516 }
else if (!SETKINDG(
mem) && !USEKINDG(
mem) && (
offset = KINDG(
mem)) &&
15517 (
val = PARMINITG(
mem))) {
15519 for (curr = dl; curr; curr = curr->next) {
15525 for (curr = dl; curr;) {
15539 typedef struct dtyList {
15541 struct dtyList *
next;
15544 typedef struct char_info {
15548 struct char_info *
next;
15551 static DL *dl =
NULL;
15552 DL *curr, *newdl, *
prev;
15555 CL *ccl, *newcl, *pcl;
15560 for (pcl = ccl =
cl; ccl;) {
15577 DTYPE mem_dtype = DTYPEG(
mem);
15578 if (PTRVG(
mem) || DESCARRAYG(
mem)) {
15581 if (PARENTG(
mem)) {
15583 BZERO(newdl, DL, 1);
15584 newdl->dtype =
dtype;
15592 int ast =
DTY(mem_dtype + 1);
15595 for (ccl =
cl; ccl; ccl = ccl->next) {
15596 if (ccl->dtype == mem_dtype && ccl->situation) {
15600 if (A_TYPEG(
ast) != A_CNST) {
15603 if (A_TYPEG(
i) == A_CNST) {
15607 if (
i == -1 ||
i == -2) {
15613 newcl->dtype = mem_dtype;
15614 newcl->situation = 2;
15615 newcl->ast = LENG(
mem);
15618 ALLOCATTRP(
mem, 1);
15620 goto shared_alloc_char;
15622 interr(
"put_length_type_param: unexpected len type param", 0,
15629 DTY(mem_dtype + 1) =
i;
15631 }
else if (A_TYPEG(
i) != A_CNST) {
15632 DTY(mem_dtype + 1) =
i;
15636 if (!ALLOCG(
mem) && !ALLOCATTRG(
mem) && !POINTERG(
mem))
15642 (
DTY(mem_dtype) ==
TY_CHAR) ? DT_DEFERCHAR : DT_DEFERNCHAR);
15643 if (SDSCG(
mem) || STYPEG(SDSCG(
mem)) != ST_MEMBER) {
15650 DTY(mem_dtype + 1) =
i;
15655 if (
DTY(mem_dtype) == TY_ARRAY && !DESCARRAYG(
mem)) {
15656 int numdim,
i, num_ast;
15660 DTYPEP(
mem, mem_dtype);
15666 for (
i = 0;
i < numdim;
i++) {
15667 int lb,
ub, bndast, con;
15669 if (SDSCG(
mem) != 0) {
15676 if (bndast != 0 && A_ALIASG(bndast) == 0) {
15680 if (A_TYPEG(
ast) != A_CNST) {
15681 if (!ALLOCG(
mem) && !ALLOCATTRG(
mem) && !POINTERG(
mem))
15696 con = USEDEFERG(
mem) && A_TYPEG(
ub) == A_BINOP
15701 if (A_TYPEG(
ub) == A_BINOP && flag < 3) {
15705 if (!USEDEFERG(
mem) && A_TYPEG(
ub) == A_BINOP) {
15708 A_LOPP(
ub, A_LOPG(bndast));
15709 A_ROPP(
ub, A_ROPG(bndast));
15710 A_DTYPEP(
ub, A_DTYPEG(bndast));
15713 if (bndast != 0 && A_ALIASG(bndast) == 0) {
15715 if (
ast <= 0 || A_TYPEG(
ast) == A_CNST) {
15717 if (con2 <= 0 && (con == -1 || con == -2))
15723 if (USELENG(
mem)) {
15724 if (!ALLOCG(
mem) && !ALLOCATTRG(
mem) && !POINTERG(
mem))
15729 if (!SDSCG(
mem) || STYPEG(SDSCG(
mem)) != ST_MEMBER) {
15735 if (USEDEFERG(
mem)) {
15737 int mem1 = SYMLKG(
mem);
15738 int sdsc_mem = mem1;
15739 if (sdsc_mem == MIDNUMG(
mem) || PTRVG(sdsc_mem)) {
15740 sdsc_mem = mem2 = SYMLKG(sdsc_mem);
15742 if (PTRVG(sdsc_mem) || !DESCARRAYG(sdsc_mem)) {
15743 sdsc_mem = mem3 = SYMLKG(sdsc_mem);
15746 if (DESCARRAYG(sdsc_mem)) {
15748 USEDEFERP(mem1,
TRUE);
15750 USEDEFERP(mem2,
TRUE);
15752 USEDEFERP(mem3,
TRUE);
15784 for (curr = dl; curr;) {
15823 int lop, rop,
sptr;
15824 switch (A_TYPEG(
ast)) {
15827 if (DESCARRAYG(
sptr) && sdsc !=
sptr &&
15829 return mk_id(sdsc);
15835 if (lop != 0 || rop != 0) {
15837 rop != 0 ? rop : A_ROPG(
ast), A_DTYPEG(
ast));
15859 if (PARENTG(
mem)) {
15864 if (LENPARMG(
mem) ==
num) {
15865 if (!flag || DEFERLENG(
mem) || ASZG(
mem)) {
15870 val[1] = PARMINITG(
mem);
15892 if (PARENTG(
mem)) {
15897 if (LENPARMG(
mem) && !ASZG(
mem))
15906 int mem, mem_dtype;
15909 mem_dtype = DTYPEG(
mem);
15910 if (PARENTG(
mem)) {
15913 if (!SETKINDG(
mem) && !USEKINDG(
mem) && KINDG(
mem) && !LENPARMG(
mem) &&
15916 "Missing constant value for kind type parameter",
SYMNAME(
mem));
15932 DTYPE mem_dtype = DTYPEG(
mem);
15933 if (PARENTG(
mem)) {
15938 if (expr && A_TYPEG(expr) != A_CNST) {
15940 "Kind type parameter value must be a compile-time constant"
15944 if (
DTY(mem_dtype) != TY_ARRAY) {
15955 ty =
DTY(mem_dtype);
15960 if (
ast > 0 && A_TYPEG(
ast) == A_CNST) {
15962 }
else if (
ast > 0) {
15964 "Kind type parameter value must be a compile-time constant"
15971 out_dtype = mem_dtype;
15973 ty =
DTY(out_dtype);
15980 ast =
DTY(mem_dtype + 1);
15981 switch (A_TYPEG(
ast)) {
16001 DTY(mem_dtype + 1) =
ast;
16002 DTYPEP(
mem, out_dtype);
16006 DTYPE base_dtype =
DTY(mem_dtype + 1);
16015 ty =
DTY(base_dtype);
16019 out_dtype =
get_type(2, ty,
DTY(base_dtype + 1));
16020 ast =
DTY(base_dtype + 1);
16025 DTY(mem_dtype + 1) = out_dtype;
16028 DTY(base_dtype + 1) =
ast;
16031 }
else if (flag <= 0 && !SETKINDG(
mem) && !USEKINDG(
mem) &&
16040 if (LENPARMG(
mem)) {
16043 if (flag == 0 && !LENPARMG(
mem) && expr &&
16045 error(155, 3,
gbl.lineno,
"Constant expression required for KIND type"
16064 if (DEFERLENG(
mem)) {
16065 if (!LENPARMG(
mem)) {
16067 "Deferred type parameter (:) cannot be used with non-length type "
16071 if (!ALLOCATTRG(
sptr) && !POINTERG(
sptr)) {
16073 "A deferred type parameter (:) must be used with "
16074 " an allocatable or pointer object",
16079 if (!LENPARMG(
mem)) {
16081 "Assumed type parameter (*) cannot be used with non-length type "
16085 if (SCG(
sptr) != SC_DUMMY) {
16087 "An assumed type parameter (*) cannot be used with non-dummy "
16100 for (; sym >
NOSYM; sym = SYMLKG(sym)) {
16101 if (PARENTG(sym)) {
16103 if (parent_vtoff > vtoff) {
16104 vtoff = parent_vtoff;
16109 if (VTOFFG(BINDG(sym)) > vtoff) {
16110 vtoff = VTOFFG(BINDG(sym));
16121 int sptr =
getsymf(
"_f03_unl_poly$%d", mem_dtype);
16123 if (STYPEG(
sptr) == ST_UNKNOWN) {
16138 DTYPEP(
mem, mem_dtype);
16162 typedef struct visitDty {
16164 struct visitDty *
next;
16168 VISITDTY *curr, *new_visit, *
prev;
16174 if (
DTY(dty) == TY_ARRAY)
16175 dty =
DTY(dty + 1);
16177 if (
DTY(dty) != TY_DERIVED) {
16183 if (curr->dty == dty) {
16189 NEW(new_visit, VISITDTY, 1);
16190 new_visit->dty = dty;
16194 for (rslt = 0, member =
DTY(dty + 1); member >
NOSYM;
16195 member = SYMLKG(member)) {
16196 if (!USEKINDG(member) && KINDG(member)) {
16232#ifdef FLANG_SEMANT_UNUSED
16234has_length_type_parameter(
int dtype)
16242 if (PARENTG(
mem) && has_length_type_parameter(DTYPEG(
mem)))
16244 if (!USEKINDG(
mem) && KINDG(
mem) && LENPARMG(
mem)) {
16266 if (USELENG(
mem)) {
16283 if (PARENTG(
mem)) {
16286 if (!USEKINDG(
mem) && (
p = KINDG(
mem))) {
16312 if (PARENTG(
mem)) {
16317 if (prev_mem ==
NOSYM) {
16320 SYMLKP(prev_mem, new_mem);
16338 int first_mem =
NOSYM;
16339 int curr_mem =
NOSYM;
16348 DINITP(
sptr, DINITG(tag));
16360 VARIANTP(new_mem, curr_mem);
16362 ADDRESSP(new_mem, 0);
16363 if (first_mem ==
NOSYM) {
16364 first_mem = new_mem;
16366 SYMLKP(curr_mem, new_mem);
16368 curr_mem = new_mem;
16373 if (MIDNUMG(
mem) && STYPEG(MIDNUMG(
mem)) == ST_MEMBER) {
16374 int mid_mem = SYMLKG(
mem);
16375 if (PTRVG(mid_mem) &&
16378 MIDNUMP(
mem, mid_mem);
16379 off_mem = SYMLKG(mid_mem);
16380 if (PTROFFG(
mem) && STYPEG(PTROFFG(
mem)) == ST_MEMBER)
16381 PTROFFP(
mem, off_mem);
16385 if (SDSCG(
mem) && STYPEG(
mem) == ST_MEMBER) {
16388 if (sdsc_mem >
NOSYM && DESCARRAYG(sdsc_mem)) {
16390 SDSCP(
mem, sdsc_mem);
16393 descr = DESCRG(
mem);
16397 DESCRP(
mem, new_descr);
16398 SECDSCP(new_descr,
match_memname(SECDSCG(new_descr), first_mem));
16399 ARRAYP(new_descr,
match_memname(ARRAYG(new_descr), first_mem));
16423 if (
DTY(
src->dtype) == TY_DERIVED) {
16441 if (NMPTRG(
sptr) == NMPTRG(
mem)) {
16452 return DTY(
dtype) == TY_DERIVED &&
16551 "PROCEDURE component must have the POINTER attribute -",
16557 if (stype != ST_MEMBER) {
16560 if (STYPEG(
sptr) != ST_UNKNOWN)
16563 STYPEP(
sptr, ST_MEMBER);
16567 if (!proc_interf_sptr) {
16568 error(155, 3,
gbl.lineno,
"The NOPASS attribute must be present for",
16622 "PROCEDURE component must have the POINTER attribute -",
16629 error(155, 3,
gbl.lineno,
"The POINTER attribute must be present for",
16635 STYPEP(
sptr, stype);
16639 }
else if (proc_interf_sptr) {
16640 dtype = DTYPEG(proc_interf_sptr);
16645 if (stype == ST_PROC) {
16646 if (proc_interf_sptr && (!
gbl.currsub || SCG(
sptr))) {
16664 if (proc_interf_sptr) {
16665 DTY(
dtype + 2) = proc_interf_sptr;
16676 if (STYPEG(
sptr) != ST_VAR || !IS_PROC_DUMMYG(
sptr))
16687 if (stype == ST_MEMBER) {
16698 PROTECTEDP(
sptr, 1);
16710 if (in_ENTRY && FVALG(func_sptr) != 0) {
16711 if (func_result_sptr)
16712 error(155, 3,
gbl.lineno,
"The ENTRY cannot have a result name -",
16716 if (func_result_sptr != 0) {
16718 RESULTP(func_sptr,
TRUE);
16720 DCLDP(func_sptr,
TRUE);
16725 STYPEP(func_result_sptr, ST_IDENT);
16727 SCP(func_result_sptr, SC_DUMMY);
16729 NODESCP(func_result_sptr,
TRUE);
16730 IGNOREP(func_result_sptr,
TRUE);
16733 if (in_ENTRY && RESULTG(func_result_sptr) != 0) {
16738 DTYPEP(func_sptr, DTYPEG(func_result_sptr));
16740 if (DTYPEG(func_sptr)) {
16742 DTYPEP(func_result_sptr, DTYPEG(func_sptr));
16743 ADJLENP(func_result_sptr, ADJLENG(func_sptr));
16745 RESULTP(func_result_sptr,
TRUE);
16747 FVALP(func_sptr, func_result_sptr);
16748 if (DCLDG(func_sptr))
16749 DCLDP(func_result_sptr,
TRUE);
16766 if (STYPEG(
sptr) == ST_PD) {
16771 if (STYPEG(
sptr) == ST_PROC) {
16795 return "END_MODULE";
void(F90_Desc *sd, __NELEM_T *nelem, __INT_T *kind, __INT_T *len, __STAT_T *stat, char **pointer, __POINT_T *offset, __INT_T *firsttime, __NELEM_T *align, DCHAR(errmsg) DCLEN64(errmsg))
void sym_is_refd(int sptr)
INT cngcon(INT oldval, int oldtyp, int newtyp)
Convert constant from oldtyp to newtyp.
int mk_bnd_int(int expr)
Utility function to ensure that an expression has a type suitable for array bounds,...
int mk_subscr(int arr, int *subs, int numdim, DTYPE dtype)
INT negate_const(INT conval, DTYPE dtype)
void ast_to_comment(int ast)
void ast_visit(int old, int new)
Add an AST to the visit list.
int mk_cval(INT v, DTYPE dtype)
void mk_alias(int ast, int a_cnst)
Create an alias of ast if it isn't a constant AST. Its alias field will be set to the ast 'a_cnst'.
int mk_cnst(int cnst)
Make a constant AST given a constant symbol table pointer.
int mk_binop(int optype, int lop, int rop, DTYPE dtype)
int mk_unop(int optype, int lop, DTYPE dtype)
...
void ast_traverse(int ast, ast_preorder_fn preorder, ast_visit_fn postorder, int *extra_arg)
General ast traversal function: uses a list to keep track of the ast nodes which have been visited; i...
int mk_member(int parent, int mem, DTYPE dtype)
int complex_alias(int ast)
For an AST tree with members and subscripts, if the base variable has the PARAMG bit set and all the ...
int replace_memsym_of_ast(int ast, SPTR sptr)
Generate a replacement AST with a new sptr for certain AST types.
void ast_implicit(int firstc, int lastc, DTYPE dtype)
int mk_cval1(INT v, DTYPE dtype)
Make a constant AST given the actual (single word) value or a constant symbol table pointer; determin...
int mk_subscr_copy(int arr, int asd, DTYPE dtype)
int mk_shared_extent(int lb, int ub, int dim)
int mk_convert(int lop, DTYPE dtype)
void ast_init(void)
Initialize AST table for new user program unit.
int sym_of_ast(int ast)
Like memsym_of_ast(), but for a member, returns the sptr of its parent, not the member.
int mk_stmt(int stmt_type, DTYPE dtype)
int mk_isz_cval(ISZ_T v, DTYPE dtype)
void ast_unvisit(void)
Traverse the visit list to clean up the nodes in the list.
INT const_fold(int opr, INT conval1, INT conval2, DTYPE dtype)
void add_param(int sptr)
Add parameters in the order in which they were declared.
void end_param(void)
Since a separate list is created for each parameter combination of ansi-/vax- style and constant/non-...
void bblock_init()
Called from semant_init().
void setfile(int f, const char *funcname, int tag)
...
function prototypes and macros for ccffinfo. Function prototypes and macros for common compiler feedb...
static uint2 uint32_t uint32_t c
LOGICAL dinit_ok(int sptr)
...
void dinit_no_dinitp(VAR *ivl, ACL *ict)
void df_dinit(VAR *ivl, ACL *ict)
void dinit(VAR *ivl, ACL *ict)
void direct_loop_end(int beg_line, int end_line)
Re-initialize the loop structure.
int chk_kind_parm_set_expr(int ast, DTYPE dtype)
LOGICAL is_procedure_dtype(DTYPE dtype)
Test if a data type index corresponds with a procedure.
LOGICAL is_array_dtype(DTYPE dtype)
...
int get_struct_initialization_tree(DTYPE dtype)
void chkstruct(DTYPE dtype)
Compute size and alignment of struct and union types and their members.
LOGICAL is_empty_typedef(DTYPE dtype)
Check for special case of empty typedef which has a size of 0 but one member of type DT_NONE to indic...
void set_proc_ptr_param_count_dtype(DTYPE ptr_dtype, int param_count)
Set paramter count for a procedure pointer type.
void set_proc_result_dtype(DTYPE proc_dtype, DTYPE result_dtype)
Set return type for a procedure type.
void set_proc_ptr_result_dtype(DTYPE ptr_dtype, DTYPE result_dtype)
Set return type for a procedure pointer.
LOGICAL eq_dtype2(DTYPE d1, DTYPE d2, LOGICAL flag)
In the presence of modules and interface blocks, it's possible that two identical derived types are n...
LOGICAL has_tbp_or_final(DTYPE dtype)
DTYPE get_type(int n, TY_KIND v1, int v2)
...
LOGICAL is_procedure_ptr_dtype(DTYPE dtype)
Test if a data type index corresponds with a procedure pointer.
ISZ_T ad_val_of(int sym)
...
int string_length(DTYPE dtype)
Return length of constant char string data type.
LOGICAL has_finalized_component(SPTR sptr)
DTYPE array_element_dtype(DTYPE dtype)
if array datatype, returns the element dtype, else returns dtype
SPTR get_struct_tag_sptr(DTYPE dtype)
DTYPE dup_array_dtype(DTYPE o_dt)
Duplicate a dtype array record and its array descriptor.
ISZ_T size_of(DTYPE dtype)
...
SPTR get_struct_members(DTYPE dtype)
void __INT_T __INT_T __STAT_T char __POINT_T * offset
directive/pragma data structures.
File Information Header (FIH)
#define BCOPY(p, q, dt, n)
void * get_getitem_p(int)
returns the pointer stored at index i.
void end_contained(void)
called at end of processing contains subprograms
int put_getitem_p(void *)
stores the pointer in the pointer table and returns its index.
#define WINNT_NOMIXEDSTRLEN
#define NEED(n, p, dt, size, newsize)
void init_named_array_constant(int, int)
Initialize a named array constant (array PARAMETER), ensuring that it's only being done within the co...
int queue_tbp(int sptr, int bind, int offset, int dtype, tbpTask task)
Main function for processing type bound procedures (tbps), generic type bound procedures,...
int get_static_type_descriptor(int sptr)
Return the "static type descriptor" for object sptr. The static type descriptor holds the "declared t...
void link_members(STSK *, int)
Link together members of a structure.
void mk_assumed_shape(SPTR)
void check_no_scope_sptr(void)
DTYPE select_kind(DTYPE, int, INT)
#define NEED_DOIF(df, typ)
int refsym_inscope(int, OVCLASS)
Similar to refsym() except that the current scope is taken into consideration.
LOGICAL cuda_enabled(const char *)
If we are accepting cuda syntax return TRUE. Otherwise issue an error message and return FALSE.
void link_parents(STSK *, int)
Link parents for type extension by adding parent as a member to the type.
void add_overload(int, int)
void gen_deallocate_arrays(void)
Generate deallocates for the temporary arrays in the sem.p_delloc list.
int get_construct_name(void)
void mk_defer_shape(SPTR)
void add_auto_finalize(int)
int declref(int, SYMTYPE, int)
Look up symbol having a specific symbol type.
int sym_in_scope(int, OVCLASS, int *, int *, int)
Look for a symbol with same name as first and in an active scope.
int get_intrinsic_opr(int, int)
ACL * mk_init_intrinsic(AC_INTRINSIC)
int ref_ident_inscope(int)
void defer_arg_chk(SPTR formal, SPTR actual, SPTR subprog, cmp_interface_flags, int lineno, bool performChk)
Process information for deferred interface argument checking in in the compat_arg_lists() function be...
void check_defined_io(void)
int mod_type(int, int, int, int, int, int)
Return a new data type based on the rules of applying a length specifier to an existing base data typ...
int get_nml_array(int)
Create the array (ST_PLIST) representing the namelist.
void save_struct_init(ACL *)
void save_host_state(int)
Called from semant.c to save the semant, sym, dtype, ast, and other 'state' information from a host r...
int get_intrinsic_oprsym(int, int)
void restore_host_state(int)
Called at the end of an internal subprogram.
void xrefput(int symptr, int usage)
Write one reference record to Reference File:
void dummy_program(void)
Check whether there is a subprogram statement; if not, create a dummy program symbol,...
int declsym(int, SYMTYPE, LOGICAL)
Declare a new symbol.
ACL * eval_init_expr(ACL *e)
int newsym(int)
Reset fields of intrinsic or generic symbol, sptr, to zero in preparation for changing its symbol typ...
SPTR get_param_alias_var(SPTR, DTYPE)
void semfin(void)
Finalize semantic processing.
#define DI_ENCL_BLOCK_SCOPE(d)
void fix_type_param_members(SPTR, DTYPE)
void restore_internal_subprograms(void)
Called at the beginning of a subprogram in pass 2.
void fix_class_args(int sptr)
Add type descriptor arguments to a specified function if they have not already been added.
void enforce_denorm(void)
int mk_set_type_call(int arg0, int arg1, LOGICAL intrin_type)
Creates an ast that represents a call to a set type runtime routine.
SPTR block_local_sym(SPTR)
Return a symbol local to the current BLOCK if applicable.
void chk_struct_constructor(ACL *)
int have_module_state(void)
void copy_specifics(int fromsptr, int tosptr)
ACL * dinit_struct_vals(ACL *, DTYPE, SPTR)
In DATA statement, do the stuff in dinit_struct_const in two steps.
ACL * construct_acl_from_ast(int, DTYPE, int)
void set_construct_name(int name)
int refsym(int, OVCLASS)
Look up a symbol having the given overloading class.
ISZ_T size_of_array(DTYPE)
Check if array has zero size.
int sem_strcmp(const char *, const char *)
Compare str and pattern like strcmp() but ignoring the case of str. pattern is all lower case.
void fixup_reqgs_ident(int sptr)
LOGICAL use_opt_atomic(int)
Decide to use optimized atomic usage.
void semfin_free_memory(void)
Deallocate data structures for semantic analysis.
ACL * rewrite_acl(ACL *, DTYPE, int)
int ref_ident(int)
Reference a symbol when it's known the context requires an identifier.
void sem_err104(int, int, const char *)
int getocsym(int, OVCLASS, LOGICAL)
Look up symbol matching overloading class of given symbol type.
void err307(const char *, int, int)
void sem_import_sym(int)
IMPORT symbol from host scope – not to be confused with interf import stuff.
LOGICAL ast_isparam(int ast)
void clean_struct_default_init(int)
void add_type_param_initialize(int)
int select_gsame(int)
Given a generic intrinsic, select the corresponding specific of the same name.
void init_intrinsic_opr(void)
SPTR lookupsymbol(const char *name)
Get the symbol table index for a NUL-terminated name.
SPTR lookupsymf(const char *fmt,...)
Construct a name via printf-style formatting and then look it up in the symbol table via lookupsymbol...
#define HASH_STR(hv, p, len)
#define HASH_ID(hv, p, len)
#define AD_EXTNTAST(p, i)
#define ADD_LWAST(dtyp, i)
#define ADD_NOBOUNDS(dtyp)
(Fortran) declarations needed to use dinitutil.c module.
Fortran semantic analyzer data definitions.
static struct @80 ss[SHIFTMAX]
void import_init(void)
Initialize import of module symbols, etc.
static int new_dtype(int)
Various definitions and prototypes for importing/exporting modules and IPA information.
static void init(int argc, char *argv[])
Initialize Fortran frontend at the beginning of compilation.
void begin_contains(void)
void add_use_stmt()
Process a "USE module" statement. The module is specified in module_id.
void mod_end_subprogram(void)
SPTR add_use_rename(SPTR local, SPTR global, LOGICAL is_operator)
Process a USE ONLY statement, optionally renaming 'global' as 'local'. The module is specified in 'mo...
LOGICAL get_seen_contains(void)
void open_module(SPTR use)
Begin processing a USE statement. use - sym ptr of module identifer in use statement Find or create a...
void apply_use_stmts(void)
SPTR begin_submodule(SPTR id, SPTR ancestor_mod, SPTR parent_submod, SPTR *parent)
void mod_end_subprogram_two(void)
int mod_add_subprogram(int subp)
SPTR begin_module(SPTR id)
void mod_implicit(int firstc, int lastc, int dtype)
void add_submodule_use(void)
void init_use_stmts(void)
static int value(int ast)
LOGICAL is_executable(int tkntyp)
#define assert(cond, txt, val, sev)
void interr(const char *txt, int val, enum error_severity sev)
Assert that cond is true, and emit an internal compiler error otherwise.
static void error(char *)
int get_local_multiplier(int sdsc, int dim)
void set_preserve_descriptor(int d)
void get_static_descriptor(int sptr)
int sym_get_sdescr(int sptr, int rank)
int get_descriptor_sc(void)
int get_extent(int sdsc, int dim)
void set_descriptor_rank(int r)
void get_all_descriptors(int sptr)
void set_descriptor_sc(int sc)
int get_named_stmtyp(void)
void scan_include(char *str)
data declarations for those items which are set by the scanner for use by the parser or semantic anal...
void scopestack_init()
Initialize the scope stack.
void push_scope_level(int sptr, SCOPEKIND kind)
Push a slot on the scope stack.
void pop_scope_level(SCOPEKIND kind)
static int construct_name
static void init_allocatable_typedef_components(int)
int cmp_len_parms(int ast1, int ast2)
static void do_iface(int)
static ACL * dup_acl(ACL *src, int sptr)
int queue_type_param(int sptr, int dtype, int offset, int flag)
Sets up type parameters used in parameterized derived types (PDTs)
static void end_subprogram_checks()
static void _do_iface(int, int)
static int fixup_KIND_expr(int ast)
static void check_duplicate(bool checker, const char *op)
Emit a warning if a duplicate subproblem prefix is used.
int get_len_parm_by_number(int num, int dtype, int flag)
static int replace_sdsc_in_ast(int sdsc, int ast)
static void set_char_attributes(int, int *)
static LOGICAL entry_seen
static void convert_intrinsics_to_idents(void)
static void search_kind(int ast, int *offset)
static void clear_iface(int i, SPTR iface)
static void chk_initialization_with_kind_parm(int)
static LOGICAL wrong_name(SPTR endname)
LOGICAL put_kind_type_param(DTYPE dtype, int offset, int value, int expr, int flag)
static void chk_new_param_dt(int, int)
static LOGICAL is_pdt_dtype(DTYPE dtype)
static void get_retval_derived_type()
static void record_func_result(int func_sptr, int func_result_sptr, LOGICAL in_ENTRY)
DTYPE create_parameterized_dt(DTYPE dtype, LOGICAL force)
Create a parameterized derived type based on dtype. If force is not set and dtype is already a PDT,...
static struct @155 entity_attr
int has_type_parameter(int dtype)
checks to see if derived type record, dtype, has any type parameters (kind or length type parameters)...
static void fix_iface0()
This routine sets the PASS field in a procedure pointer for semantic pass 0 prior to call to end_modu...
static void get_retval_LEN_value()
static int get_highest_param_offset(int)
static int create_var(int)
static LOGICAL ignore_common_decl(void)
static void do_iface_module(void)
static void defer_iface(int, int, int, int)
static void check_kind_type_param(int dtype)
static void gen_unique_func_ast(int ast, SPTR sptr, SST *stkptr)
static void gen_dinit(int, SST *)
static int get_kind_parm(int, int)
void semant_init(int noparse)
Initialize semantic analyzer for new user subprogram unit.
static void set_len_attributes(SST *, int)
int internal_proc_has_ident(int ident, int proc)
bool in_intrinsic_decl(void)
Return the predicate: current entity has the INTRINSIC attribute.
static struct @154 lenspec[2]
static void fix_iface(int)
#define BYVALDEFAULT(ffunc)
static void do_end_subprogram(SST *, RU_TYPE)
static LOGICAL in_entity_typdcl
static int get_len_parm(int, int)
static LOGICAL craft_intrinsics
static void fixup_param_vars(SST *, SST *)
static void copy_type_to_entry(int)
static struct dec_attr_t dec_attr
static void restore_host(INTERF *, LOGICAL)
static int get_procedure_stype(int attr)
Determine procedure symbol type for a set of attributes.
void put_length_type_param(DTYPE dtype, int flag)
int get_unl_poly_sym(int mem_dtype)
int defer_pt_decl(int dtype, int flag)
Store dtypes of parameterized derived types in which a parameter was explicitly declared (as opposed ...
static int get_kind_parm_strict(int, int)
static void check_end_subprogram(RU_TYPE, int)
static void reloc_byvalue_parameters()
static bool bindingNameRequiresOverloading(SPTR sptr)
Determine if a type bound procedure (tbp) binding name requires overloading.
static struct dec_attr_t bind_attr
static void pop_subprogram(void)
static int create_func_entry_result(int)
static int match_memname(int sptr, int list)
static void save_typedef_init(int, int)
static void defer_put_kind_type_param(int, int, char *, int, int, int)
static IFACE * iface_base
DTYPE get_parameterized_dt(DTYPE dtype)
Duplicate dtype by creating a new derived type with a $pt suffix. For use with processing parameteriz...
static int eval_KIND_expr(int ast, int *val, int *dtyp)
int chk_kind_parm_expr(int ast, int dtype, int flag, int strict_flag)
int get_parm_by_number(int offset, int dtype)
search derived type for a type parameter in the same position as specified by offset.
static int chk_intrinsic(int, LOGICAL, LOGICAL)
static void clear_ident_list()
static void process_bind(int)
int all_len_parms_assumed(int dtype)
Return 0 if there's at least one length type parameter that is not assumed. Otherwise return 1.
static LOGICAL seen_options
int chk_len_parm_expr(int ast, int dtype, int flag)
int get_entity_access()
provide the current entity's access to other source files.
static void check_module_prefix()
MODULE prefix checking for subprograms C1547: cannot be inside a an abstract interface.
static void ctte(int entry, int sptr)
static int chk_asz_deferlen(int, int)
static IDENT_LIST * ident_base[HASHSIZE]
static LOGICAL dirty_ident_base
static void decr_ident_use(int ident, int proc)
static void save_host(INTERF *)
static struct @156 et[ET_MAX]
int getMscall()
provide mscall variable state to other source files.
void semant1(int rednum, SST *top)
Semantic actions - part 1.
static void fix_proc_ptr_dummy_args()
static int chk_kind_parm(SST *)
static void get_retval_KIND_value()
static LOGICAL is_exe_stmt
const char * sem_pgphase_name()
char bounds[sizeof(sem.bounds)]
static int decl_procedure_sym(int sptr, int proc_interf_sptr, int attr)
Declare a procedure symbol.
static void defer_ident_list(int ident, int proc)
static struct @157 da[DA_MAX]
static LOGICAL seen_implicit
static bool do_fixup_param_vars_for_derived_arrays(bool, SPTR, int)
To re-initialize an array of derived types when found the following conditions are satisfied:
static int chk_func_entry_result(int)
int getCref()
provide cref variable state to other source files.
int get_kind_parm_by_name(char *np, int dtype)
search a derived type for a kind type parameter with a specified name.
static int create_func_entry(int)
static void clear_subp_prefix_settings(struct subp_prefix_t *)
Reset subprogram prefixes to zeroes.
char arrdim[sizeof(sem.arrdim)]
void put_default_kind_type_param(int dtype, int flag, int flag2)
static struct subp_prefix_t subp_prefix
int get_len_set_parm_by_name(char *np, int dtype, int *val)
static void fixup_function_return_type(int, int)
int get_parm_by_name(char *np, int dtype)
search a derived type for a kind or length type parameter with a specified name.
static int has_type_parameter2(int dtype, int visit_flag)
Returns true if dtype is a derived type that has a type parameter or if it has a component that has a...
static LOGICAL seen_parameter
static void set_string_type_from_init(int, ACL *)
static int ident_host_sub
static void symatterr(int, int, const char *)
int has_length_type_parameter_use(int dtype)
static int setup_procedure_sym(int sptr, int proc_interf_sptr, int attr, char access)
Process procedure declaration.
int is_parameter_context()
allow other source files to check whether we're processing a parameter construct.
static void get_param_alias_const(SST *, int, int)
static void replace_sdsc_in_bounds(int sdsc, ADSC *ad, int i)
void build_typedef_init_tree(int sptr, int dtype)
static int has_kind_parm_expr(int, int, int)
static int get_vtoff(int, DTYPE)
static void set_aclen(SST *, int, int)
static const char * name_of_rutype(RU_TYPE)
static struct cl_tag cl[CL_MAXV]
#define SST_SUBSCRIPTP(p, v)
#define SST_NMLBEGP(p, v)
int mkvarref(SST *, ITEM *)
Make a var ref of the form: <var primary> ( [<ssa list>] )
void constant_lvalue(SST *)
If stkptr is an LVALUE that has a constant value, replace it with the constant value.
#define SST_ERRSYMP(p, v)
#define SST_SUBSTRINGG(p)
INT chkcon(SST *, int, LOGICAL)
Check that the indicated semantic stack entry is a constant of the specified type and convert constan...
#define SST_NMLENDP(p, v)
#define SST_GDTYPEP(p, v)
ISZ_T chkcon_to_isz(SST *, LOGICAL)
Check that the indicated semantic stack entry is a constant of any integer type.
#define SST_SUBSTRINGP(p, v)
VAR * dinit_varref(SST *)
Create an initialization node for a variable reference in a data statement.
void dinit_struct_param(SPTR, ACL *, DTYPE)
void construct_acl_for_sst(SST *, DTYPE)
#define SST_OPTYPEP(p, v)
void ch_substring(SST *, SST *, SST *)
Substring of a character constant.
INT chk_scalartyp(SST *, int, LOGICAL)
Same as chktyp() with the restriction that the expression must be a scalar (i.e., not an array/vector...
#define SST_SUBSCRIPTG(p)
#define SST_OFFSETP(p, v)
INT chk_arr_extent(SST *, const char *)
Restrict the expression to be suitable for an array extent.
int mklvalue(SST *, int)
Check for legal variable to be assigned to.
INT chktyp(SST *, int, LOGICAL)
Convert expression pointed to by stkptr from its current data type to data type dtype.
gbldefs.h - syminit/symutil utility definitions
const char * atypes[AST_MAX+1]
Deferred procedure interface.
struct SEM::@179 mpaccatomic
LOGICAL ignore_default_none
ITEM * alloc_mem_initialize
struct _sem_arrdim arrdim
struct SEM::@178 critical
int deferred_kind_len_lineno
struct _sem_bounds bounds[MAXDIMS]
OVCLASS ovclass[ST_MAX+1]
struct VAR::@256::@257 dostart
struct VAR::@256::@259 varref
struct VAR::@256::@258 doend
IDENT_PROC_LIST * proc_list
struct ident_proc_list * next
struct sst::@188::@190 cnval
Subprogram prefix struct defintions for RECURESIVE, PURE, IMPURE, ELEMENTAL, and MODULE.
SPTR instantiate_interface(SPTR iface)
Instantiate a copy of a separate module subprogram's declared interface as part of the MODULE PROCEDU...
int add_symitem(int sptr, int nxt)
...
int getccsym(int letter, int n, SYMTYPE stype)
void proc_arginfo(int sptr, int *paramct, int *dpdsc, int *iface)
void newimplicitnone(void)
void change_predefineds(int stype, LOGICAL remove)
SPTR find_explicit_interface(SPTR s)
void copy_sym_flags(SPTR dest, SPTR src)
Copy flags from one symbol to another symbol.
void reinit_sym(int sptr)
int getccsym_sc(int letter, int n, int stype, int sc)
INT get_int_cval(int con)
int getsym(const char *name, int olength)
Enter symbol with indicated name into symbol table, initialize the new entry.
LOGICAL is_procedure_ptr(int sptr)
void save_implicit(LOGICAL reset)
void newimplicit(int firstc, int lastc, int dtype)
Change the current settings for implicit variable types and character lengths.
int getsymbol(const char *name)
...
void dup_sym(int new, SYM *content)
int insert_dup_sym(int sptr)
bool cmp_interfaces_strict(SPTR sym1, SPTR sym2, cmp_interface_flags flag)
Same as cmp_interfaces() except we also compare the characteristics as defined in "12....
int getsymf(const char *fmt,...)
ISZ_T get_isz_cval(int con)
...
int resolve_sym_aliases(int sptr)
void pop_sym(int sptr)
remove a symbol from its hash list
bool cmp_interfaces(int sym1, int sym2, int flag)
Compares two symbols by returning true if they both have equivalent interfaces. Otherwise,...
void restore_implicit(void)
int getstring(const char *value, int length)
Enter character constant into symbol table and return pointer to it.
SPTR getcon(INT *value, DTYPE dtype)
Enter constant of given dtype and value into the symbol table and return pointer to it.
void setimplicit(int sptr)
...
int insert_sym(int first)
int sym_get_scalar(const char *basename, const char *purpose, int dtype)
int get_next_hash_link(int sptr, int task)
utility function for visiting symbols of a specified name.
int findByNameStypeScope(char *symname, int stype, int scope)
utility function for finding a symbol in the symbol table that has a specified name.
int find_dummy_position(int proc_sptr, int arg_sptr)
SPTR get_member_descriptor(int sptr)
int get_next_sym(const char *basename, const char *purpose)
#define FLANG_FALLTHROUGH
FLANG_FALLTHROUGH - Mark fallthrough cases in switch statements.